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)))