[mcclim-cvs] CVS mcclim
dlichteblau
dlichteblau at common-lisp.net
Tue Dec 26 16:44:45 UTC 2006
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]
More information about the Mcclim-cvs
mailing list