December 2006 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 29 Dec '06

29 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17226 Modified Files: pango.lisp Log Message: Readable rendering in Closure. * Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Interpret font sizes as pixels again, not points. Default font sizes would have been too -small- now, adjust them a little. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/26 12:11:04 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/29 18:10:48 1.6 @@ -119,13 +119,22 @@ (if (eq family :fixed) :fix family)) (error "unknown font family: ~A" family)))) (size (case size - (:normal 12) - (:tiny 6) - (:small 10) - (:very-small 8) - (:large 14) - (:very-large 16) - (:huge 24) + ;; points: +;;; (:tiny 6) +;;; (:very-small 8) +;;; (:small 10) +;;; (:normal 12) +;;; (:large 14) +;;; (:very-large 16) +;;; (:huge 24) + ;; pixels: + (:tiny 8) + (:very-small 11) + (:small 13) + (:normal 16) + (:large 18) + (:very-large 21) + (:huge 32) (otherwise (truncate size)))) desc) (if (stringp face) @@ -148,7 +157,7 @@ (pango_font_description_set_weight desc weight) (pango_font_description_set_style desc style))) (pango_font_description_set_family desc family) - (pango_font_description_set_size desc (* size PANGO_SCALE)) + (pango_font_description_set_absolute_size desc (df (* size PANGO_SCALE))) desc))) (defun pango-layout-get-pixel-size (layout)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 28 Dec '06

28 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28511 Modified Files: medium.lisp Log Message: Really fix scrambled pixmap masks. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:26:33 1.77 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:30:40 1.78 @@ -430,8 +430,6 @@ ;; Create an xlib "image" and copy it to our pixmap. ;; I do this because I'm not smart enough to operate xlib:put-raw-image. (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth - :bit-lsb-first-p t - :byte-lsb-first-p t :width w :height h :format :z-pixmap :data converted-data))) @@ -450,6 +448,8 @@ ;; We can use image upload for the mask in either case. (let ((mask-image (xlib:create-image :bits-per-pixel 1 :depth 1 + :bit-lsb-first-p t + :byte-lsb-first-p t :width w :height h :data mask-data))) (xlib:put-image mask mask-gc mask-image

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 28 Dec '06

28 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28249 Modified Files: medium.lisp Log Message: Fix scrambled pixmap masks on big-endian hosts. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/19 02:16:38 1.76 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:26:33 1.77 @@ -430,6 +430,8 @@ ;; Create an xlib "image" and copy it to our pixmap. ;; I do this because I'm not smart enough to operate xlib:put-raw-image. (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth + :bit-lsb-first-p t + :byte-lsb-first-p t :width w :height h :format :z-pixmap :data converted-data)))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 27 Dec '06

27 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17453/Backends/gtkairo Modified Files: event.lisp gadgets.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/10 19:33:05 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/27 14:47:24 1.18 @@ -269,31 +269,43 @@ (defvar *last-seen-button* 3) -(define-signal button-handler (widget event) +(defgeneric handle-event-p (sheet event)) + +(defmethod handle-event-p (sheet event) + t) + +(define-signal (button-handler :return-type :int) (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) (setf *last-seen-button* button) - (enqueue - (make-instance (if (eql type GDK_BUTTON_PRESS) - 'pointer-button-press-event - 'pointer-button-release-event) - :pointer 0 - :button (ecase button - (1 +pointer-left-button+) - (2 +pointer-middle-button+) - (3 +pointer-right-button+) - (4 +pointer-wheel-up+) - (5 +pointer-wheel-down+)) - :x (truncate x) - :y (truncate y) - :graft-x (truncate x_root) - :graft-y (truncate y_root) - :sheet (widget->sheet widget *port*) - :modifier-state (gdkmodifiertype->modifier-state state) - :timestamp time)))) + (let* ((sheet (widget->sheet widget *port*)) + (event + (make-instance (if (eql type GDK_BUTTON_PRESS) + 'pointer-button-press-event + 'pointer-button-release-event) + :pointer 0 + :button (ecase button + (1 +pointer-left-button+) + (2 +pointer-middle-button+) + (3 +pointer-right-button+) + (4 +pointer-wheel-up+) + (5 +pointer-wheel-down+)) + :x (truncate x) + :y (truncate y) + :graft-x (truncate x_root) + :graft-y (truncate y_root) + :sheet sheet + :modifier-state (gdkmodifiertype->modifier-state state) + :timestamp time))) + (cond + ((handle-event-p sheet event) + (enqueue event) + 1) + (t + 0))))) (define-signal enter-handler (widget event) (cffi:with-foreign-slots --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/25 19:41:46 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/27 14:47:24 1.20 @@ -250,6 +250,33 @@ (mapcar (climi::list-pane-value-key pane) (climi::list-pane-items pane))) +(defmethod handle-event-p + ((pane gtk-list) (event pointer-button-press-event)) + (eql (pointer-event-button event) +pointer-right-button+)) + +(defun gtk-list-one-value (pane) + (if (eq (climi::list-pane-mode pane) :exclusive) + (if (and (slot-boundp pane 'climi::value) + ;; FIXME: we still assume NIL == no value + (gadget-value pane)) + (values (gadget-value pane) t) + (values nil nil)) + (if (and (slot-boundp pane 'climi::value) + (eql 1 (length (gadget-value pane)))) + (values (car (gadget-value pane)) t) + (values nil nil)))) + +(defmethod handle-event ((pane gtk-list) (event pointer-button-press-event)) + (multiple-value-bind (value valuep) (gtk-list-one-value pane) + (when valuep + (let* ((i (position value (climi::generic-list-pane-item-values pane))) + (item (elt (climi::list-pane-items pane) i))) + (climi::meta-list-pane-call-presentation-menu pane item))))) + +(defmethod handle-event-p + ((pane gtk-list) (event pointer-button-release-event)) + nil) + (defun option-pane-set-active (sheet widget) (gtk_combo_box_set_active widget @@ -422,8 +449,10 @@ ) (defmethod connect-native-signals ((sheet gtk-list) widget) - ;; no signals - ) + (setf (widget->sheet (list-pane-tree-view sheet) (port sheet)) sheet) + (connect-signal (list-pane-tree-view sheet) + "button-press-event" + 'button-handler)) (defmethod connect-native-signals ((sheet gtk-label-pane) widget) ;; no signals

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 27 Dec '06

27 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv17453/Examples Modified Files: demodemo.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/24 14:27:48 1.16 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/27 14:47:24 1.17 @@ -218,7 +218,9 @@ (make-pane 'list-pane :value 'clim:region-intersection :items (apropos-list "INTER" :clim t) - :name-key (lambda (x) (format nil "~(~S~)" x))))) + :presentation-type-key (constantly 'list-test-symbol) + :name-key (lambda (x) (format nil "~(~S~)" x)))) + (interactor :interactor :height 200)) (:layouts (defaults (labelling (:label "Matching symbols" @@ -230,7 +232,17 @@ substring (make-pane 'push-button :label "Update" - :activate-callback 'update-list-test))))))) + :activate-callback 'update-list-test)) + interactor))))) + +(define-presentation-type list-test-symbol ()) + +(define-list-test-command com-describe-symbol + ((sym 'list-test-symbol :gesture :select)) + ;; Let's print only three lines, we don't have space for more. + (with-input-from-string (s (with-output-to-string (s) (describe sym s))) + (dotimes (x 3) + (write-line (read-line s nil "") *standard-input*)))) (defun update-list-test (pane) (declare (ignore pane))

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 27 Dec '06

27 Dec '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17453 Modified Files: gadgets.lisp Log Message: As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item. If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called. In addition, right click will be recognized on the list pane and open a presentation menu. * gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/23 21:44:03 1.102 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/27 14:47:23 1.103 @@ -1917,7 +1917,11 @@ :initform #'identity :reader list-pane-value-key :documentation "A function to be applied to items to gain its value - for the purpose of GADGET-VALUE.") + for the purpose of GADGET-VALUE.") + (presentation-type-key :initarg :presentation-type-key + :initform (constantly nil) + :reader list-pane-presentation-type-key + :documentation "A function to be applied to items to find the presentation types for their values, or NIL.") (test :initarg :test :initform #'eql :reader list-pane-test @@ -1970,6 +1974,16 @@ (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected."))) +(defmethod value-changed-callback + :before + ((gadget meta-list-pane) client gadget-id value) + (declare (ignore client gadget-id)) + (let* ((i (position value (generic-list-pane-item-values gadget))) + (item (elt (list-pane-items gadget) i)) + (ptype (funcall (list-pane-presentation-type-key gadget) item))) + (when ptype + (throw-object-ptype value ptype)))) + (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive) (eql (list-pane-mode pane) :one-of))) @@ -2163,11 +2177,47 @@ (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event)) (generic-list-pane-handle-click pane x y (event-modifier-state event)))) +(defclass ad-hoc-presentation (standard-presentation) ()) + +(defmethod output-record-hit-detection-rectangle* + ((presentation ad-hoc-presentation)) + (values most-negative-fixnum most-negative-fixnum + most-positive-fixnum most-positive-fixnum)) + +(defun generic-list-pane-handle-right-click (pane event) + (multiple-value-bind (x y) + (values (pointer-event-x event) (pointer-event-y event)) + (multiple-value-bind (item-value index) + (generic-list-pane-item-from-x-y pane x y) + (let* ((item (elt (list-pane-items pane) index))) + (meta-list-pane-call-presentation-menu pane item))))) + +(defun meta-list-pane-call-presentation-menu (pane item) + (let ((ptype (funcall (list-pane-presentation-type-key pane) item))) + (when ptype + (let ((presentation + (make-instance 'ad-hoc-presentation + :object (funcall (list-pane-value-key pane) item) + :single-box t + :type ptype))) + (call-presentation-menu + presentation + *input-context* + *application-frame* + pane + 42 42 + :for-menu t + :label (format nil "Operation on ~A" ptype)))))) + (defmethod handle-event ((pane generic-list-pane) (event pointer-button-press-event)) - (if (eql (pointer-event-button event) +pointer-left-button+) - (progn (generic-list-pane-handle-click-from-event pane event) - (setf (slot-value pane 'armed) nil)) - (when (next-method-p) (call-next-method)))) + (case (pointer-event-button event) + (#.+pointer-left-button+ + (generic-list-pane-handle-click-from-event pane event) + (setf (slot-value pane 'armed) nil)) + (#.+pointer-right-button+ + (generic-list-pane-handle-right-click pane event)) + (t + (when (next-method-p) (call-next-method))))) (defmethod handle-event ((pane generic-list-pane) (event pointer-button-release-event)) (if (eql (pointer-event-button event) +pointer-left-button+)

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 26 Dec '06

26 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv20946 Modified Files: cairo.lisp Log Message: Repair "Show Directory" on the cairo medium. * Backends/gtkairo/cairo.lisp (make-cairo-surface): Updated enum name. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 16:44:46 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 17:29:49 1.3 @@ -555,8 +555,8 @@ ;;;; General Designs ;;;; -(defun make-cairo-surface - (compatible-medium width height &optional (format :argb32)) +(defun make-cairo-surface (compatible-medium width height + &optional (format :CAIRO_CONTENT_COLOR_ALPHA)) (let* ((s (cairo_surface_create_similar (cairo_get_target (cr compatible-medium)) format width height))

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 26 Dec '06

26 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv14010/Examples Modified Files: clim-fig.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/19 04:08:58 1.30 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/12/26 16:44:46 1.31 @@ -31,7 +31,7 @@ (setf (gadget-value (clim-fig-status *application-frame*)) string)) -(defun draw-figure (pane x y x1 y1 &key fastp) +(defun draw-figure (pane x y x1 y1 &key fastp cp-x1 cp-y1 cp-x2 cp-y2) (with-slots (line-style current-color fill-mode constrict-mode) *application-frame* (let* ((radius-x (- x1 x)) @@ -70,7 +70,23 @@ (:ellipse (draw-ellipse* pane x y radius-x 0 0 radius-y :filled fill-mode - :ink current-color :line-style line-style)))))) + :ink current-color :line-style line-style)) + (:bezier + (when fastp + (draw-text* pane + "[Use the middle and right mouse button to set control points]" + 0 + 20)) + (let* ((cp-x1 (or cp-x1 x)) + (cp-y1 (or cp-y1 y1)) + (cp-x2 (or cp-x2 x1)) + (cp-y2 (or cp-y2 y)) + (design (climi::make-bezier-thing* + 'climi::bezier-area + (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1)))) + (climi::draw-bezier-design* pane design) + (draw-line* pane x y cp-x1 cp-y1 :ink +red+) + (draw-line* pane x1 y1 cp-x2 cp-y2 :ink +blue+))))))) (defun signum-1 (value) (if (zerop value) @@ -87,7 +103,8 @@ (defun handle-draw-object (pane x1 y1) (let* ((pixmap-width (round (bounding-rectangle-width (sheet-region pane)))) (pixmap-height (round (bounding-rectangle-height (sheet-region pane)))) - (canvas-pixmap (allocate-pixmap pane pixmap-width pixmap-height))) + (canvas-pixmap (allocate-pixmap pane pixmap-width pixmap-height)) + cp-x1 cp-y1 cp-x2 cp-y2) (copy-to-pixmap pane 0 0 pixmap-width pixmap-height canvas-pixmap) (multiple-value-bind (x y) (block processor @@ -105,17 +122,29 @@ (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (draw-figure pane x1 y1 x y - :fastp t))) - (:pointer-button-release (&key event x y) + :fastp t + :cp-x1 cp-x1 :cp-y1 cp-y1 + :cp-x2 cp-x2 :cp-y2 cp-y2))) + (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-left-button+) - (return-from processor (values x y))))))) + (return-from processor (values x y)))) + (:pointer-button-press (&key event x y) + (cond + ((= (pointer-event-button event) + +pointer-right-button+) + (setf cp-x1 x cp-y1 y)) + ((= (pointer-event-button event) + +pointer-middle-button+) + (setf cp-x2 x cp-y2 y))))))) (set-status-line " ") (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (deallocate-pixmap canvas-pixmap) (with-output-as-presentation (pane nil 'figure :single-box t) - (draw-figure pane x1 y1 x y)) + (draw-figure pane x1 y1 x y + :cp-x1 cp-x1 :cp-y1 cp-y1 + :cp-x2 cp-x2 :cp-y2 cp-y2)) (setf (clim-fig-redo-list *application-frame*) nil)))) (defun handle-move-object (pane figure first-point-x first-point-y) @@ -248,6 +277,7 @@ (arrow-button (make-drawing-mode-button "Arrow" :arrow)) (rectangle-button (make-drawing-mode-button "Rectangle" :rectangle)) (ellipse-button (make-drawing-mode-button "Ellipse" :ellipse)) + (bezier-button (make-drawing-mode-button "Bezier" :bezier)) ;; Colors (black-button (make-colored-button +black+)) @@ -293,7 +323,8 @@ round-shape-toggle (horizontally () fill-mode-toggle constrict-toggle) point-button line-button arrow-button - ellipse-button rectangle-button) + ellipse-button rectangle-button + bezier-button) (scrolling (:width 600 :height 400) canvas)) (horizontally (:height 30) clear undo redo) status)))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 26 Dec '06

26 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14010/Backends/gtkairo Modified Files: cairo.lisp ffi.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 16:44:46 1.2 @@ -703,3 +703,51 @@ design (draw-design medium background) (draw-design medium foreground)))) + + +;;;; Bezier support + +(defmethod climi::medium-draw-bezier-design* + ((medium cairo-medium) (design climi::bezier-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)) + (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)))) + +(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))) + +(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-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))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/25 19:55:11 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/26 16:44:46 1.15 @@ -317,6 +317,11 @@ (arg4 :pointer) ;double * ) +(defcfun "cairo_fill_preserve" + :pointer + (arg0 :pointer) ;cairo_t * + ) + (defcfun "cairo_font_extents" :void (arg0 :pointer) ;cairo_t * @@ -672,6 +677,11 @@ (arg0 :pointer) ;cairo_t * ) +(defcfun "cairo_stroke_preserve" + :void + (arg0 :pointer) ;cairo_t * + ) + (defcfun "cairo_stroke_extents" :void (arg0 :pointer) ;cairo_t *

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 26 Dec '06

26 Dec '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14010 Modified Files: NEWS mcclim.asd Added Files: bezier.lisp Log Message: With Robert Strandh's permission, move gsharp/bezier.lisp into McCLIM. All symbols are still in the CLIMI package and undocumented, but should ultimately move into CLIME or a new package. Try CLIM-FIG or gsharp to test. * NEWS: updated. * mcclim.asd (CLIM-BASIC): Depend on flexichain. Added bezier.lisp * bezier.lisp: New file, from gsharp. Postscript methods taken out. * Backends/PostScript/graphics.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods, from gsharp/bezier.lisp. * Backends/gtkairo/cairo.lisp (MEDIUM-DRAW-BEZIER-DESIGN*): New methods. * Backends/gtkairo/ffi.lisp: regenerated. * Examples/clim-fig.lisp (DRAW-FIGURE, HANDLE-DRAW-OBJECT): Added a bezier drawing mode. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/25 12:43:49 1.16 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/12/26 16:44:45 1.17 @@ -26,6 +26,8 @@ implemented. ** Improvement: Added font listing support, see section "Fonts and Extended Text Styles" in the manual. +** Improvement: Added support for bezier splines (Robert Strandh). + To be documented. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 12:11:04 1.44 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 16:44:45 1.45 @@ -104,7 +104,7 @@ (:file "package" :depends-on ("Lisp-Dep" "patch")))) (defsystem :clim-basic - :depends-on (:clim-lisp :spatial-trees) + :depends-on (:clim-lisp :spatial-trees :flexichain) :components ((:file "decls") (:file "protocol-classes" :depends-on ("decls")) (:module "Lisp-Dep" @@ -152,7 +152,8 @@ (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" - "events")))) + "events")) + (:file "bezier" :depends-on ("recording")))) (defsystem :goatee-core :depends-on (:clim-basic) --- /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 NONE +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 1.1 (in-package :clim-internals) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Utilities (defun point-to-complex (point) "convert a point to a complex number" (complex (point-x point) (point-y point))) (defun complex-to-point (complex) "convert a complex number to a point" (make-point (realpart complex) (imagpart complex))) (defun distance (p0 p1) "return the euclidian distance between two points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (let* ((dx (- x1 x0)) (dx2 (* dx dx)) (dy (- y1 y0)) (dy2 (* dy dy))) (sqrt (+ dx2 dy2)))))) (defun part-way (p0 p1 alpha) "return a point that is part way between two other points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (make-point (+ (* (- 1 alpha) x0) (* alpha x1)) (+ (* (- 1 alpha) y0) (* alpha y1)))))) (defun dot-dist (p p0 p1) "dot distance between a point and a line" (let ((dx (- (point-x p1) (point-x p0))) (dy (- (point-y p1) (point-y p0)))) (- (* (point-x p) dy) (* (point-y p) dx)))) (defun solve-quadratic (a2 a1 a0 &key complex-roots multiple-roots) (when (zerop a2) (return-from solve-quadratic (- (/ a0 a1)))) (unless (= a2 1) (setf a1 (/ a1 a2) a0 (/ a0 a2))) (let* ((-a1/2 (- (/ a1 2.0))) (r (- (* -a1/2 -a1/2) a0))) (cond ((zerop r) (if multiple-roots (values -a1/2 -a1/2) -a1/2)) ((minusp r) (if complex-roots (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))) (values))) (t (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))))))) (defun dist (v z) "compute the distance between a point and a vector represented as a complex number" (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) (defclass bezier-design (design) ()) (defgeneric medium-draw-bezier-design* (stream design)) (defclass bezier-design-output-record (standard-graphics-displayed-output-record) ((stream :initarg :stream) (design :initarg :design))) (defmethod initialize-instance :after ((record bezier-design-output-record) &key) (with-slots (design) record (setf (rectangle-edges* record) (bounding-rectangle* design)))) (defmethod medium-draw-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) (let ((record (make-instance 'bezier-design-output-record :stream stream :design transformed-design))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) (medium-draw-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-bezier-design* (sheet-medium stream) design))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Bezier curves and areas (defclass bezier-segment () ((p0 :initarg :p0) (p1 :initarg :p1) (p2 :initarg :p2) (p3 :initarg :p3))) (defun make-bezier-segment (p0 p1 p2 p3) (make-instance 'bezier-segment :p0 p0 :p1 p1 :p2 p2 :p3 p3)) (defclass bounding-rectangle-mixin () ((min-x) (min-y) (max-x) (max-y))) (defmethod bounding-rectangle* ((region bounding-rectangle-mixin)) (with-slots (min-x min-y max-x max-y) region (values min-x min-y max-x max-y))) (defclass segments-mixin (bounding-rectangle-mixin) ((%segments :initarg :segments :initform '() :reader segments))) (defun compute-bounding-rectangle* (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)) 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) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (values final-min-x final-min-y final-max-x final-max-y))) (defmethod initialize-instance :after ((region segments-mixin) &rest args) (declare (ignore args)) (multiple-value-bind (computed-min-x computed-min-y computed-max-x computed-max-y) (compute-bounding-rectangle* region) (with-slots (min-x min-y max-x max-y) region (setf min-x computed-min-x min-y computed-min-y max-x computed-max-x max-y computed-max-y)))) ;;; a path defined as a sequence of Bezier curve segments (defclass bezier-curve (path segments-mixin bounding-rectangle-mixin) ()) (defun make-bezier-thing (class point-seq) (assert (= (mod (length point-seq) 3) 1)) (make-instance class :segments (loop for (p0 p1 p2 p3) on point-seq by #'cdddr until (null p1) collect (make-bezier-segment p0 p1 p2 p3)))) (defun make-bezier-thing* (class coord-seq) (assert (= (mod (length coord-seq) 6) 2)) (make-instance class :segments (loop for (x0 y0 x1 y1 x2 y2 x3 y3 x4 y4) on coord-seq by #'(lambda (x) (nthcdr 6 x)) until (null x1) collect (make-bezier-segment (make-point x0 y0) (make-point x1 y1) (make-point x2 y2) (make-point x3 y3))))) (defun make-bezier-curve (point-seq) (make-bezier-thing 'bezier-curve point-seq)) (defun make-bezier-curve* (coord-seq) (make-bezier-thing* 'bezier-curve coord-seq)) (defun transform-segment (transformation segment) (with-slots (p0 p1 p2 p3) segment (make-bezier-segment (transform-region transformation p0) (transform-region transformation p1) (transform-region transformation p2) (transform-region transformation p3)))) (defmethod transform-region (transformation (path bezier-curve)) (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) (segments path)))) (defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) (and (<= (abs (- (point-x p1) (point-x p2))) coordinate-epsilon) (<= (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)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve :segments (append (segments r1) (cons (make-bezier-segment p p1 p2 p3) (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) ()) (defgeneric close-path (path)) (defmethod close-path ((path bezier-curve)) (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)) (defun path-end (path) (slot-value (car (last (segments path))) 'p3)) (defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) (make-bezier-thing 'bezier-area point-seq)) (defun make-bezier-area* (coord-seq) (assert (and (coordinate= (car coord-seq) (car (last coord-seq 2))) (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 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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Special cases of combined Bezier areas ;;; 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))) (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))) (defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) (bounding-rectangle* (car areas)) (loop for area in (cdr areas) do (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* area) (setf final-min-x (min final-min-x min-x) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (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))) (defmethod region-union ((r1 bezier-area) (r2 bezier-area)) (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)))) (defmethod region-union ((r1 bezier-area) (r2 bezier-union)) (make-instance 'bezier-union :areas (cons r1 (areas r2)))) (defmethod region-union ((r1 bezier-union) (r2 bezier-union)) (make-instance 'bezier-union :areas (append (areas r1) (areas r2)))) (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))) (defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-area)) (make-instance 'bezier-difference :positive-areas (list r1) :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))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) (make-instance 'bezier-difference :positive-areas (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Converting a path to a polyline or an area to a polygon ;;; convert a cubic bezier segment to a list of ;;; line segments (defun %polygonalize (p0 p1 p2 p3 &key (precision 0.01)) (if (< (- (+ (distance p0 p1) (distance p1 p2) (distance p2 p3)) (distance p0 p3)) precision) (list p3) (let* ((p01 (part-way p0 p1 0.5)) (p12 (part-way p1 p2 0.5)) (p23 (part-way p2 p3 0.5)) (p012 (part-way p01 p12 0.5)) (p123 (part-way p12 p23 0.5)) (p0123 (part-way p012 p123 0.5))) (nconc (%polygonalize p0 p01 p012 p0123 :precision precision) (%polygonalize p0123 p123 p23 p3 :precision precision))))) (defgeneric polygonalize (thing)) (defmethod polygonalize ((segment bezier-segment)) (with-slots (p0 p1 p2 p3) segment (%polygonalize p0 p1 p2 p3))) (defmethod polygonalize ((path bezier-curve)) (let ((segments (segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) (defmethod polygonalize ((area bezier-area)) (let ((segments (segments area))) (make-polygon (mapcan #'polygonalize segments)))) [479 lines skipped]

1 0