mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by rstrandh 18 Jul '07

18 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8060 Modified Files: events.lisp Log Message: Avoid compiler warnings about implicit creation of generic functions. --- /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/29 10:43:36 1.29 +++ /project/mcclim/cvsroot/mcclim/events.lisp 2007/07/18 16:57:14 1.30 @@ -158,13 +158,19 @@ (defmethod pointer-event-y ((event pointer-event)) (get-pointer-position ((event-sheet event) event) y)) +(defgeneric pointer-event-position* (pointer-event)) + (defmethod pointer-event-position* ((event pointer-event)) (get-pointer-position ((event-sheet event) event) (values x y))) +(defgeneric device-event-x (device-event)) + (defmethod device-event-x ((event device-event)) (get-pointer-position ((event-sheet event) event) x)) +(defgeneric device-event-y (device-event)) + (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) @@ -237,9 +243,13 @@ (declare (ignorable x y)) ,@body)) +(defgeneric window-configuration-event-x (window-configuration-event)) + (defmethod window-configuration-event-x ((event window-configuration-event)) (get-window-position ((event-sheet event) event) x)) +(defgeneric window-configuration-event-y (window-configuration-event)) + (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y))

1 0

[mcclim-cvs] CVS mcclim
by rstrandh 18 Jul '07

18 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4744 Modified Files: recording.lisp Log Message: Added IGNORE declarations to avoid warnings about unused variables. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/15 12:38:37 1.133 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/18 16:31:27 1.134 @@ -1083,6 +1083,7 @@ (defmethod replay-output-record :around ((record gs-ink-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :ink (graphics-state-ink record)) (call-next-method))) @@ -1111,6 +1112,7 @@ (defmethod replay-output-record :around ((record gs-clip-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :clipping-region (graphics-state-clip record)) (call-next-method))) @@ -1140,6 +1142,7 @@ (defmethod replay-output-record :around ((record gs-line-style-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :line-style (graphics-state-line-style record)) (call-next-method))) @@ -1166,6 +1169,7 @@ (defmethod replay-output-record :around ((record gs-text-style-mixin) stream &optional region x-offset y-offset) + (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :text-style (graphics-state-text-style record)) (call-next-method))) @@ -1688,7 +1692,6 @@ :text-style text-style)) ) (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) - (height (+ ascent descent)) (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y))

1 0

[mcclim-cvs] CVS mcclim/Backends/Null
by rstrandh 17 Jul '07

17 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv24460 Modified Files: graft.lisp medium.lisp port.lisp Log Message: Added IGNORE declarations to avoid compiler warnings. --- /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2007/07/17 15:58:47 1.2 @@ -23,7 +23,9 @@ ()) (defmethod graft-width ((graft null-graft) &key (units :device)) - ()) + (declare (ignore units)) + nil) (defmethod graft-height ((graft null-graft) &key (units :device)) - ()) + (declare (ignore units)) + nil) --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 12:03:31 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2007/07/17 15:58:47 1.3 @@ -23,18 +23,22 @@ ((buffering-output-p :accessor medium-buffering-output-p))) (defmethod (setf medium-text-style) :before (text-style (medium null-medium)) - ()) + (declare (ignore text-style)) + nil) (defmethod (setf medium-line-style) :before (line-style (medium null-medium)) - ()) + (declare (ignore line-style)) + nil) (defmethod (setf medium-clipping-region) :after (region (medium null-medium)) - ()) + (declare (ignore region)) + nil) (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable null-medium) to-x to-y) + (declare (ignore from-x from-y width height to-x to-y)) nil) #+nil ; FIXME: PIXMAP class @@ -43,26 +47,34 @@ from-x from-y width height (to-drawable pixmap) to-x to-y) + (declare (ignore from-x from-y width height to-x to-y)) nil) + (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable null-medium) to-x to-y) - ()) + (declare (ignore from-x from-y width height to-x to-y)) + nil) + (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) - ())) + (declare (ignore from-x from-y width height to-x to-y)) + nil)) (defmethod medium-draw-point* ((medium null-medium) x y) - ()) + (declare (ignore x y)) + nil) (defmethod medium-draw-points* ((medium null-medium) coord-seq) - ()) + (declare (ignore coord-seq)) + nil) (defmethod medium-draw-line* ((medium null-medium) x1 y1 x2 y2) - ()) + (declare (ignore x1 y1 x2 y2)) + nil) ;; FIXME: Invert the transformation and apply it here, as the :around ;; methods on transform-coordinates-mixin will cause it to be applied @@ -74,33 +86,50 @@ nil)) (defmethod medium-draw-polygon* ((medium null-medium) coord-seq closed filled) - ()) + (declare (ignore coord-seq closed filled)) + nil) (defmethod medium-draw-rectangle* ((medium null-medium) left top right bottom filled) - ()) + (declare (ignore left top right bottom filled)) + nil) + (defmethod medium-draw-rectangles* ((medium null-medium) position-seq filled) - ()) + (declare (ignore position-seq filled)) + nil) (defmethod medium-draw-ellipse* ((medium null-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) - ()) + (declare (ignore center-x center-y + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy + start-angle end-angle filled)) + nil) (defmethod medium-draw-circle* ((medium null-medium) center-x center-y radius start-angle end-angle filled) - ()) + (declare (ignore center-x center-y radius + start-angle end-angle filled)) + nil) (defmethod text-style-ascent (text-style (medium null-medium)) + (declare (ignore text-style)) 1) + (defmethod text-style-descent (text-style (medium null-medium)) + (declare (ignore text-style)) 1) + (defmethod text-style-height (text-style (medium null-medium)) (+ (text-style-ascent text-style medium) (text-style-descent text-style medium))) + (defmethod text-style-character-width (text-style (medium null-medium) char) + (declare (ignore text-style char)) 1) + ;;; FIXME: this one is nominally backend-independent (defmethod text-style-width (text-style (medium null-medium)) (text-style-character-width text-style medium #\m)) @@ -134,11 +163,16 @@ start end align-x align-y toward-x toward-y transform-glyphs) - ()) + (declare (ignore string x y + start end + align-x align-y + toward-x toward-y transform-glyphs)) + nil) #+nil (defmethod medium-buffering-output-p ((medium null-medium)) t) + #+nil (defmethod (setf medium-buffering-output-p) (buffer-p (medium null-medium)) buffer-p) @@ -146,18 +180,23 @@ (defmethod medium-draw-glyph ((medium null-medium) element x y align-x align-y toward-x toward-y transform-glyphs) - ()) + (declare (ignore element x y + align-x align-y toward-x toward-y + transform-glyphs)) + nil) (defmethod medium-finish-output ((medium null-medium)) - ()) + nil) + (defmethod medium-force-output ((medium null-medium)) - ()) + nil) (defmethod medium-clear-area ((medium null-medium) left top right bottom) - ()) + (declare (ignore left top right bottom)) + nil) (defmethod medium-beep ((medium null-medium)) - ()) + nil) (defmethod invoke-with-special-choices (continuation (medium null-medium)) (let ((sheet (medium-sheet medium))) --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/02/07 12:44:19 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/07/17 15:58:47 1.4 @@ -80,19 +80,20 @@ (defmethod port-set-sheet-region ((port null-port) (sheet mirrored-sheet-mixin) region) - ()) + (declare (ignore region)) + nil) (defmethod port-enable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod port-disable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod destroy-port :before ((port null-port)) - ()) + nil) (defmethod port-motion-hints ((port null-port) (mirror mirrored-sheet-mixin)) - ()) + nil) (defmethod (setf port-motion-hints) (value (port null-port) (sheet mirrored-sheet-mixin)) @@ -100,7 +101,8 @@ (defmethod get-next-event ((port null-port) &key wait-function (timeout nil)) - ()) + (declare (ignore wait-function timeout)) + nil) (defmethod make-graft ((port null-port) &key (orientation :default) (units :device)) @@ -113,30 +115,37 @@ (defmethod text-style-mapping ((port null-port) text-style &optional character-set) - ()) + (declare (ignore text-style character-set)) + nil) (defmethod (setf text-style-mapping) (font-name (port null-port) - (text-style text-style) &optional character-set) - ()) + (text-style text-style) &optional character-set) + (declare (ignore font-name text-style character-set)) + nil) (defmethod port-character-width ((port null-port) text-style char) - ()) + (declare (ignore text-style char)) + nil) (defmethod port-string-width ((port null-port) text-style string &key (start 0) end) - ()) + (declare (ignore text-style string start end)) + nil) (defmethod port-mirror-width ((port null-port) sheet) - ()) + (declare (ignore sheet)) + nil) (defmethod port-mirror-height ((port null-port) sheet) - ()) + (declare (ignore sheet)) + nil) (defmethod graft ((port null-port)) (first (climi::port-grafts port))) (defmethod port-allocate-pixmap ((port null-port) sheet width height) - ()) + (declare (ignore sheet width height)) + nil) (defmethod port-deallocate-pixmap ((port null-port) pixmap) #+nil @@ -147,16 +156,17 @@ (values (slot-value pointer 'x) (slot-value pointer 'y))) (defmethod pointer-button-state ((pointer null-pointer)) - ()) + nil) (defmethod port-modifier-state ((port null-port)) - ()) + nil) (defmethod synthesize-pointer-motion-event ((pointer null-pointer)) - ()) + nil) (defmethod port-frame-keyboard-input-focus ((port null-port) frame) (frame-properties frame 'focus)) + (defmethod (setf port-frame-keyboard-input-focus) (focus (port null-port) frame) (setf (frame-properties frame 'focus) focus)) @@ -165,35 +175,44 @@ focus) (defmethod port-keyboard-input-focus ((port null-port)) - ()) + nil) (defmethod port-force-output ((port null-port)) - ()) + nil) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port null-port) pointer sheet) - ()) + (declare (ignore pointer sheet)) + nil) (defmethod port-ungrab-pointer ((port null-port) pointer sheet) - ()) + (declare (ignore pointer sheet)) + nil) (defmethod distribute-event :around ((port null-port) event) - ()) + (declare (ignore event)) + nil) (defmethod set-sheet-pointer-cursor ((port null-port) sheet cursor) - ()) + (declare (ignore sheet cursor)) + nil) (defmethod bind-selection ((port null-port) window &optional time) - ()) + (declare (ignore window time)) + nil) (defmethod release-selection ((port null-port) &optional time) - ()) + (declare (ignore time)) + nil) (defmethod request-selection ((port null-port) requestor time) - ()) + (declare (ignore requestor time)) + nil) (defmethod get-selection-from-event ((port null-port) event) - ()) + (declare (ignore event)) + nil) (defmethod send-selection ((port null-port) event string) + (declare (ignore event string)) nil)

1 0

[mcclim-cvs] CVS mcclim
by crhodes 17 Jul '07

17 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20781 Modified Files: bezier.lisp Log Message: In bezier area/curve convolution, don't put the area (pen) down quite so often: reduces redundant areas in unions from draw-path in gsharp. (Also rename convlute -> convolve) --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/11 15:26:20 1.2 +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/17 06:36:01 1.3 @@ -568,7 +568,13 @@ (add-points p1 left) (add-points p0 left)) (make-line-segment (add-points p0 left) (add-points p0 right))))))) -(defun convolute-polygon-and-segment (area polygon segment) +(defun area-at-point (area point) + (let ((transformation + (make-translation-transformation (point-x point) (point-y point)))) + (transform-region transformation area))) + +(defun convolve-polygon-and-segment (area polygon segment first) + (declare (optimize debug)) (let* ((points (polygon-points polygon)) (sides (loop for (p0 p1) on (append (last points) points) until (null p1) @@ -576,24 +582,20 @@ (split-points (find-split-points sides segment)) (segments (split-segment segment split-points))) (loop for segment in segments - append (list (let* ((p (slot-value segment 'p0)) - (transformation (make-translation-transformation - (point-x p) (point-y p)))) - (transform-region transformation area)) - (convert-primitive-segment-to-bezier-area (polygon-points polygon) - segment) - (let* ((p (slot-value segment 'p3)) - (transformation (make-translation-transformation - (point-x p) (point-y p)))) - (transform-region transformation area)))))) + if first collect (area-at-point area (slot-value segment 'p0)) + collect (convert-primitive-segment-to-bezier-area + (polygon-points polygon) segment) + collect (area-at-point area (slot-value segment 'p3))))) -(defgeneric convolute-regions (area path)) +(defgeneric convolve-regions (area path)) -(defmethod convolute-regions ((area bezier-area) (path bezier-curve)) +(defmethod convolve-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) - (make-instance 'bezier-union - :areas (loop for segment in (%segments path) - append (convolute-polygon-and-segment area polygon segment))))) + (make-instance + 'bezier-union :areas + (loop for segment in (%segments path) + for first = t then nil + append (convolve-polygon-and-segment area polygon segment first))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -793,6 +795,7 @@ (defmethod medium-draw-bezier-design* (medium design) (render-through-pixmap design medium)) +#| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Test cases @@ -806,3 +809,4 @@ (defparameter *r4* (make-bezier-curve* '(100 100 120 150 160 160 170 160))) (defparameter *r5* (convolute-regions *r2* *r4*)) +|#

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 15 Jul '07

15 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10361 Modified Files: recording.lisp Log Message: Fixed bug reported by Fred Gilham, [mcclim-devel] Tooltip stuff * recording.lisp (erase-output-record): Lock the bounding rectangle to the pixel grid and add extra safety at the borders to avoid leaving fragments on the border. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/06/03 18:47:03 1.132 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/07/15 12:38:37 1.133 @@ -2048,10 +2048,20 @@ when (eq parent nil) do (return nil) when (eq parent ancestor) do (return t))) +(defun rounded-bounding-rectangle (region) + ;; return a bounding rectangle whose coordinates have been rounded to + ;; lock into the pixel grid. Includes some extra safety to make + ;; sure antialiasing around the theoretical limits are included, too. + (with-bounding-rectangle* (x1 y1 x2 y2) region + (make-rectangle* (floor (- x1 0.5)) + (floor (- y1 0.5)) + (ceiling (+ x2 0.5)) + (ceiling (+ y2 0.5))))) + (defmethod erase-output-record (record (stream standard-output-recording-stream) &optional (errorp t)) (letf (((stream-recording-p stream) nil)) - (let ((region (bounding-rectangle record))) + (let ((region (rounded-bounding-rectangle record))) (with-bounding-rectangle* (x1 y1 x2 y2) region (if (output-record-ancestor-p (stream-output-history stream) record) (progn

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 15 Jul '07

15 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv28434 Modified Files: keys.lisp Log Message: german keyboard layout support (umlauts and eszett in particular) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2006/12/25 12:37:38 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/07/15 12:00:08 1.3 @@ -64,6 +64,7 @@ (DEFINE-KEY 91 (T :[ #\[)) (DEFINE-KEY 92 (T :|\\| #\\)) (DEFINE-KEY 93 (T :] #\])) +(DEFINE-KEY 94 (T :^ #\^)) (DEFINE-KEY 95 (T :_ #\_)) (DEFINE-KEY 96 (T :|`| #\`)) (DEFINE-KEY 97 (T :|a| #\a)) @@ -95,16 +96,27 @@ (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 124 (T :|\|| #\|)) (DEFINE-KEY 125 (T :} #\})) +(DEFINE-KEY 167 (T :SECTION NIL)) +(DEFINE-KEY 176 (T :DEGREE NIL)) +(DEFINE-KEY 196 (T :A-DIAERESIS #.(code-char 196))) +(DEFINE-KEY 214 (T :O-DIAERESIS #.(code-char 214))) +(DEFINE-KEY 220 (T :U-DIAERESIS #.(code-char 220))) +(DEFINE-KEY 223 (T :SSHARP #.(code-char 223))) +(DEFINE-KEY 228 (T :|a-DIAERESIS| #.(code-char 228))) +(DEFINE-KEY 246 (T :|o-DIAERESIS| #.(code-char 246))) +(DEFINE-KEY 252 (T :|u-DIAERESIS| #.(code-char 252))) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) +(DEFINE-KEY 65237 ((12) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) +(DEFINE-KEY 65288 ((4 8 0) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65289 (T :TAB #\Tab)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) -(DEFINE-KEY 65301 (T :SYS-REQ NIL)) +(DEFINE-KEY 65301 ((12 8) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) @@ -116,9 +128,11 @@ (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) +(DEFINE-KEY 65377 ((4 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) +(DEFINE-KEY 65406 (T :MODE-SWITCH NIL)) (DEFINE-KEY 65407 (T :NUM-LOCK NIL)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 65429 (T :KP-HOME NIL)) @@ -137,6 +151,11 @@ (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) +(DEFINE-KEY 65450 ((4 8 0) :KP-MULTIPLY NIL) (T NIL NIL)) +(DEFINE-KEY 65451 ((4 8 0) :KP-ADD NIL) (T NIL NIL)) +(DEFINE-KEY 65452 (T :KP-SEPARATOR NIL)) +(DEFINE-KEY 65453 ((4 8 0) :KP-SUBTRACT NIL) (T NIL NIL)) +(DEFINE-KEY 65455 ((4 8 0) :KP-DIVIDE NIL) (T NIL NIL)) (DEFINE-KEY 65456 (T :KP-0 NIL)) (DEFINE-KEY 65457 (T :KP-1 NIL)) (DEFINE-KEY 65458 (T :KP-2 NIL)) @@ -158,6 +177,18 @@ (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65480 (T :F11 NIL)) +(DEFINE-KEY 65470 ((4 8 0) :F1 NIL) (T NIL NIL)) +(DEFINE-KEY 65471 ((4 8 0) :F2 NIL) (T NIL NIL)) +(DEFINE-KEY 65472 ((4 8 0) :F3 NIL) (T NIL NIL)) +(DEFINE-KEY 65473 ((4 8 0) :F4 NIL) (T NIL NIL)) +(DEFINE-KEY 65474 ((4 8 0) :F5 NIL) (T NIL NIL)) +(DEFINE-KEY 65475 ((4 8 0) :F6 NIL) (T NIL NIL)) +(DEFINE-KEY 65476 ((4 8 0) :F7 NIL) (T NIL NIL)) +(DEFINE-KEY 65477 ((4 8 0) :F8 NIL) (T NIL NIL)) +(DEFINE-KEY 65478 ((4 8 0) :F9 NIL) (T NIL NIL)) +(DEFINE-KEY 65479 ((4 8 0) :F10 NIL) (T NIL NIL)) +(DEFINE-KEY 65480 ((4 8 0) :F11 NIL) (T NIL NIL)) +(DEFINE-KEY 65481 ((4 8 0) :F12 NIL) (T NIL NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) @@ -165,7 +196,25 @@ (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) +(DEFINE-KEY 65513 (T :ALT-LEFT NIL)) +(DEFINE-KEY 65515 (T :SUPER-LEFT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) -(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) \ No newline at end of file +(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) +(DEFINE-KEY 269024769 ((12) :F1 NIL) (T NIL NIL)) +(DEFINE-KEY 269024770 ((12) :F2 NIL) (T NIL NIL)) +(DEFINE-KEY 269024771 ((12) :F3 NIL) (T NIL NIL)) +(DEFINE-KEY 269024772 ((12) :F4 NIL) (T NIL NIL)) +(DEFINE-KEY 269024773 ((12) :F5 NIL) (T NIL NIL)) +(DEFINE-KEY 269024774 ((12) :F6 NIL) (T NIL NIL)) +(DEFINE-KEY 269024775 ((12) :F7 NIL) (T NIL NIL)) +(DEFINE-KEY 269024776 ((12) :F8 NIL) (T NIL NIL)) +(DEFINE-KEY 269024777 ((12) :F9 NIL) (T NIL NIL)) +(DEFINE-KEY 269024778 ((12) :F10 NIL) (T NIL NIL)) +(DEFINE-KEY 269024779 ((12) :F11 NIL) (T NIL NIL)) +(DEFINE-KEY 269024780 ((12) :F12 NIL) (T NIL NIL)) +(DEFINE-KEY 269024800 ((12) :KP-DIVIDE NIL) (T NIL NIL)) +(DEFINE-KEY 269024801 ((12) :KP-MULTIPLY NIL) (T NIL NIL)) +(DEFINE-KEY 269024802 ((12) :KP-ADD NIL) (T NIL NIL)) +(DEFINE-KEY 269024803 ((12) :KP-SUBTRACT NIL) (T NIL NIL))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by crhodes 11 Jul '07

11 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv13045/Backends/gtkairo Modified Files: cairo.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 17:29:49 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2007/07/11 15:26:20 1.4 @@ -707,6 +707,19 @@ ;;;; Bezier support +(defun %draw-bezier-area (medium area) + (with-slots (cr) medium + (let ((segments (climi::segments area))) + (let ((p0 (slot-value (car segments) 'climi::p0))) + (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) + (dolist (segment segments) + (with-slots (climi::p1 climi::p2 climi::p3) segment + (cairo_curve_to cr + (df (point-x climi::p1)) (df (point-y climi::p1)) + (df (point-x climi::p2)) (df (point-y climi::p2)) + (df (point-x climi::p3)) (df (point-y climi::p3))))) + (cairo_fill cr)))) + (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-area)) (with-medium (medium) @@ -715,39 +728,36 @@ (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (let ((p0 (slot-value (car (climi::segments design)) 'climi::p0))) - (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) - (dolist (segment (climi::segments design)) - (with-slots (climi::p1 climi::p2 climi::p3) segment - (cairo_curve_to cr - (df (point-x climi::p1)) (df (point-y climi::p1)) - (df (point-x climi::p2)) (df (point-y climi::p2)) - (df (point-x climi::p3)) (df (point-y climi::p3))))) - (cairo_fill cr)))) + (%draw-bezier-area medium design))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-union)) - (dolist (area (climi::areas design)) - (climi::medium-draw-bezier-design* medium area))) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (let ((tr (climi::transformation design))) + (dolist (area (climi::areas design)) + (%draw-bezier-area medium (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-difference)) - (dolist (area (climi::positive-areas design)) - (climi::medium-draw-bezier-design* medium area)) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (dolist (area (climi::positive-areas design)) + (%draw-bezier-area medium area))) (with-drawing-options (medium :ink +background-ink+) - (dolist (area (climi::negative-areas design)) - (climi::medium-draw-bezier-design* medium area)))) - -(defmethod climi::medium-draw-bezier-design* - ((medium cairo-medium) (design climi::translated-bezier-design)) - (let ((tx (climi::translation design))) - (setf tx - ;; - ;; FIXME: needed for gsharp, doesn't make sense to me - ;; - (compose-transformations tx (medium-transformation medium))) - (climi::medium-draw-bezier-design* medium - (climi::really-transform-region - tx - (climi::original-region design))))) + (with-medium (medium) + (sync-sheet medium) + (sync-transformation medium) + (sync-ink medium (medium-ink medium)) + (sync-clipping-region medium (medium-clipping-region medium)) + (sync-line-style medium (medium-line-style medium)) + (dolist (area (climi::negative-areas design)) + (%draw-bezier-area medium area)))))

1 0

[mcclim-cvs] CVS mcclim
by crhodes 11 Jul '07

11 Jul '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13045 Modified Files: bezier.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 1.1 +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/11 15:26:20 1.2 @@ -56,7 +56,8 @@ (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) -(defclass bezier-design (design) ()) +(defclass bezier-design (design) + ((%or :accessor original-region :initform nil))) (defgeneric medium-draw-bezier-design* (stream design)) @@ -80,6 +81,12 @@ (when (stream-drawing-p stream) (medium-draw-bezier-design* medium design))))) +(defmethod medium-draw-bezier-design* :around + ((medium transform-coordinates-mixin) design) + (let* ((tr (medium-transformation medium)) + (design (transform-region tr design))) + (call-next-method 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)) @@ -108,12 +115,12 @@ (values min-x min-y max-x max-y))) (defclass segments-mixin (bounding-rectangle-mixin) - ((%segments :initarg :segments :initform '() :reader segments))) + ((%segments :initarg :segments :initform '() :reader %segments))) -(defun compute-bounding-rectangle* (segments-mixin) +(defmethod compute-bounding-rectangle* ((segments-mixin segments-mixin)) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) - (segment-bounding-rectangle (car (segments segments-mixin))) - (loop for segment in (cdr (segments segments-mixin)) + (segment-bounding-rectangle (car (%segments segments-mixin))) + (loop for segment in (cdr (%segments segments-mixin)) do (multiple-value-bind (min-x min-y max-x max-y) (segment-bounding-rectangle segment) (setf final-min-x (min final-min-x min-x) @@ -171,7 +178,7 @@ (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) - (segments path)))) + (%segments path)))) (defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) @@ -179,49 +186,33 @@ (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon)))) (defmethod region-union ((r1 bezier-curve) (r2 bezier-curve)) - (let ((p (slot-value (car (last (segments r1))) 'p3)) - (seg (car (segments r2)))) + (let ((p (slot-value (car (last (%segments r1))) 'p3)) + (seg (car (%segments r2)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve - :segments (append (segments r1) + :segments (append (%segments r1) (cons (make-bezier-segment p p1 p2 p3) - (cdr (segments r2)))))) + (cdr (%segments r2)))))) (call-next-method)))) -;;; A region that translates a different region -(defclass translated-bezier-design (region bezier-design) - ((%translation :initarg :translation :reader translation) - (%region :initarg :region :reader original-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)) - (multiple-value-bind (final-min-x final-min-y) - (transform-position translation min-x min-y) - (multiple-value-bind (final-max-x final-max-y) - (transform-position translation max-x max-y) - (values final-min-x final-min-y final-max-x final-max-y)))))) - -(defgeneric really-transform-region (transformation region)) - ;;; an area defined as a closed path of Bezier curve segments -(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) +(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+))) (defgeneric close-path (path)) (defmethod close-path ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (assert (region-equal (slot-value (car segments) 'p0) (slot-value (car (last segments)) 'p3))) (make-instance 'bezier-area :segments segments))) (defun path-start (path) - (slot-value (car (segments path)) 'p0)) + (slot-value (car (%segments path)) 'p0)) (defun path-end (path) - (slot-value (car (last (segments path))) 'p3)) + (slot-value (car (last (%segments path))) 'p3)) (defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) @@ -232,18 +223,26 @@ (coordinate= (cadr coord-seq) (car (last coord-seq))))) (make-bezier-thing* 'bezier-area coord-seq)) -(defmethod really-transform-region (transformation (area bezier-area)) - (make-instance 'bezier-area - :segments (mapcar (lambda (segment) - (transform-segment transformation segment)) - (segments area)))) +(defmethod segments ((area bezier-area)) + (let ((tr (transformation area))) + (mapcar (lambda (s) (transform-segment tr s)) (%segments area)))) (defmethod transform-region (transformation (area bezier-area)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((tr (transformation area)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-area :segments (%segments area) + :transformation + (compose-transformations transformation tr)) + (make-instance 'bezier-area + :segments (mapcar (lambda (s) (transform-segment transformation s)) (segments area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result)) + +(defmethod compute-bounding-rectangle* ((area bezier-area)) + (multiple-value-bind (lx ly ux uy) (call-next-method) + (let ((tr (transformation area))) + (transform-rectangle* tr lx ly ux uy)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -251,20 +250,20 @@ ;;; A union of bezier areas. This is not itself a bezier area. (defclass bezier-union (area bezier-design) - ((%areas :initarg :areas :initform '() :reader areas))) - -(defmethod really-transform-region (transformation (area bezier-union)) - (let ((areas (loop for area in (areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-union - :areas areas))) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+) + (%areas :initarg :areas :initform '() :reader areas))) -(defmethod transform-region (transformation (area bezier-union)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) +(defmethod transform-region (transformation (union bezier-union)) + (let* ((tr (transformation union)) + (new-tr (compose-transformations transformation tr)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-union :areas (areas union) + :transformation new-tr) + (make-instance 'bezier-union + :areas (loop for area in (areas union) collect (transform-region new-tr area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region union) union))) + result)) (defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) @@ -279,43 +278,57 @@ (values final-min-x final-min-y final-max-x final-max-y))) (defmethod bounding-rectangle* ((design bezier-union)) - (bounding-rectangle-of-areas (areas design))) + (multiple-value-bind (lx ly ux uy) + (bounding-rectangle-of-areas (areas design)) + (transform-rectangle* (transformation design) lx ly ux uy))) (defmethod region-union ((r1 bezier-area) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (list r1 r2))) + (make-instance 'bezier-union :areas (list r1 r2))) (defmethod region-union ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (cons r2 (areas r1)))) + (let ((tr (transformation r1))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r2) (areas r1)) + :transformation tr))) (defmethod region-union ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (cons r1 (areas r2)))) + (let ((tr (transformation r2))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r1) (areas r2)) + :transformation tr))) (defmethod region-union ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (append (areas r1) (areas r2)))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (if (transformation-equal tr1 tr2) + (make-instance 'bezier-union + :areas (append (areas r1) (areas r2)) + :transformation tr1) + (let ((len1 (length (areas r1))) + (len2 (length (areas r2)))) + (if (> len2 len1) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr2 (transform-region tr1 r))) (areas r1)) (areas r2)) + :transformation tr2) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr1 (transform-region tr2 r))) (areas r2)) (areas r1)) + :transformation tr1)))))) (defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) -(defmethod really-transform-region (transformation (area bezier-difference)) - (let ((pareas (loop for area in (positive-areas area) - collect (transform-region transformation area))) - (nareas (loop for area in (negative-areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-difference - :positive-areas pareas - :negative-areas nareas))) - (defmethod transform-region (transformation (area bezier-difference)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((pareas (loop for area in (positive-areas area) + collect (transform-region transformation area))) + (nareas (loop for area in (negative-areas area) + collect (transform-region transformation area))) + (result (make-instance 'bezier-difference + :positive-areas pareas + :negative-areas nareas))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result)) (defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) @@ -326,19 +339,23 @@ :negative-areas (list r2))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (list r1) - :negative-areas (areas r2))) + (let ((tr (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (list r1) + :negative-areas (mapcar (lambda (r) (transform-region tr r)) (areas r2))))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (list r2))) + (let ((tr (transformation r1))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr r)) (areas r1)) + :negative-areas (list r2)))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (areas r2))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr1 r)) (areas r1)) + :negative-areas (mapcar (lambda (r) (transform-region tr2 r)) (areas r2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -369,7 +386,7 @@ (%polygonalize p0 p1 p2 p3))) (defmethod polygonalize ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) @@ -390,11 +407,12 @@ (defmethod reverse-path ((path bezier-curve)) (make-instance 'bezier-curve - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path))))) (defmethod reverse-path ((path bezier-area)) (make-instance 'bezier-area - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path))) + :transformation (transformation path))) ;;; slanting transformation are used by Metafont (defun make-slanting-transformation (slant) @@ -574,7 +592,7 @@ (defmethod convolute-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) (make-instance 'bezier-union - :areas (loop for segment in (segments path) + :areas (loop for segment in (%segments path) append (convolute-polygon-and-segment area polygon segment))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -670,9 +688,6 @@ (defmethod positive-negative-areas ((design bezier-difference)) (values (positive-areas design) (negative-areas design))) -(defmethod positive-negative-areas ((design translated-bezier-design)) - (positive-negative-areas (original-region design))) - (defun render-to-array (design) (multiple-value-bind (positive-areas negative-areas) (positive-negative-areas design) @@ -695,9 +710,6 @@ (render-polygon result polygon 1 min-x min-y))) result)))) -(defparameter *x* 0) -(defparameter *y* 0) - (defparameter *pixmaps* (make-hash-table :test #'equal)) (defun resolve-ink (medium) @@ -715,8 +727,9 @@ (defgeneric ensure-pixmap (medium design)) -(defmethod ensure-pixmap (medium design) - (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) +(defmethod ensure-pixmap (medium rdesign) + (let* ((design (or (original-region rdesign) rdesign)) + (pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) (let* ((picture (render-to-array design)) @@ -743,17 +756,21 @@ pixmap))) pixmap)) -(defmethod ensure-pixmap (medium (design translated-bezier-design)) - (ensure-pixmap medium (original-region design))) - (defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) - (setf min-x (floor min-x) - min-y (floor min-y)) - (let ((pixmap (ensure-pixmap medium design))) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) + ;; the design we've got has already been transformed by the + ;; medium/user transformation, and COPY-FROM-PIXMAP is in user + ;; coordinates. So we need to transform back (or set the medium's + ;; transformation to be +IDENTITY-TRANSFORMATION+ temporarily, but + ;; that's even uglier) + (multiple-value-bind (utmin-x utmin-y) + (untransform-position (medium-transformation medium) min-x min-y) + (setf min-x (floor utmin-x) + min-y (floor utmin-y)) + (let ((pixmap (ensure-pixmap medium design))) + (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) + (medium-sheet medium) min-x min-y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -778,73 +795,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Special cases on region-union and region-intersection - -(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-bezier-design) (r2 bezier-area)) [64 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Backends/PostScript
by crhodes 11 Jul '07

11 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv13045/Backends/PostScript Modified Files: graphics.lisp Log Message: Bezier designs which draw in the right place in all backends (I think). The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So: * define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice. * this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method. * deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap. * this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.) * the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves. Please test! --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/12/26 16:44:45 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/07/11 15:26:20 1.19 @@ -547,36 +547,44 @@ ;;; Bezier support -(defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::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 (climi::segments design)) 'climi::p0))) - (clim-postscript::write-coordinates stream (point-x p0) (point-y p0)) +(defun %draw-bezier-area (stream area) + (format stream "newpath~%") + (let ((segments (climi::segments area))) + (let ((p0 (slot-value (car segments) 'climi::p0))) + (write-coordinates stream (point-x p0) (point-y p0)) (format stream "moveto~%")) - (loop for segment in (climi::segments design) + (loop for segment in segments do (with-slots (climi::p1 climi::p2 climi::p3) segment - (clim-postscript::write-coordinates stream (point-x climi::p1) (point-y climi::p1)) - (clim-postscript::write-coordinates stream (point-x climi::p2) (point-y climi::p2)) - (clim-postscript::write-coordinates stream (point-x climi::p3) (point-y climi::p3)) + (write-coordinates stream (point-x climi::p1) (point-y climi::p1)) + (write-coordinates stream (point-x climi::p2) (point-y climi::p2)) + (write-coordinates stream (point-x climi::p3) (point-y climi::p3)) (format stream "curveto~%"))) (format stream "fill~%"))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::bezier-union)) - (dolist (area (climi::areas design)) - (climi::medium-draw-bezier-design* medium area))) + ((medium postscript-medium) (design climi::bezier-area)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (%draw-bezier-area stream design))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::bezier-difference)) - (dolist (area (climi::positive-areas design)) - (climi::medium-draw-bezier-design* medium area)) - (with-drawing-options (medium :ink +background-ink+) - (dolist (area (climi::negative-areas design)) - (climi::medium-draw-bezier-design* medium area)))) + ((medium postscript-medium) (design climi::bezier-union)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (let ((tr (climi::transformation design))) + (dolist (area (climi::areas design)) + (%draw-bezier-area stream (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* - ((medium clim-postscript::postscript-medium) (design climi::translated-bezier-design)) - (climi::medium-draw-bezier-design* medium (climi::really-transform-region (climi::translation design) (climi::original-region design)))) + ((medium postscript-medium) (design climi::bezier-difference)) + (let ((stream (postscript-medium-file-stream medium)) + (*transformation* (sheet-native-transformation (medium-sheet medium)))) + (postscript-actualize-graphics-state stream medium :color) + (dolist (area (climi::positive-areas design)) + (%draw-bezier-area stream area)) + (with-drawing-options (medium :ink +background-ink+) + (postscript-actualize-graphics-state stream medium :color) + (dolist (area (climi::negative-areas design)) + (%draw-bezier-area stream area)))))

1 0

[mcclim-cvs] CVS mcclim/Drei/cl-automaton
by dlichteblau 07 Jul '07

07 Jul '07

Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv16032 Modified Files: automaton.lisp regexp.lisp state-and-transition.lisp Log Message: make Drei source code ASCII-clean (with apologies to Anders Møller) --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/02/06 12:53:09 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/07/07 13:41:30 1.4 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders MÃžller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Functionality not used by the regular expression engine and not tested ;;; has been omitted from this initial release. ;;; - Some comments have been copied verbatim from the original code. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2007/02/06 12:53:09 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2007/07/07 13:41:30 1.3 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders MÃžller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Some comments have been copied verbatim from the original code. ;;; Regular expressions are built from the following abstract syntax: --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/02/06 12:53:09 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/07/07 13:41:30 1.4 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders MÃžller +;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller (in-package :automaton)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs