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]