March 2006 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim
by crhodes 06 Mar '06

06 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2997 Modified Files: regions.lisp Log Message: Fix a couple of region bugs * the infinite loop in point/point intersection noted in the tests * isum-member was broken for more than one rectangle in the same horizontal band. Add test for this case. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2005/02/11 10:05:57 1.30 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2006/03/06 16:09:12 1.31 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.30 2005/02/11 10:05:57 crhodes Exp $ +;;; $Id: regions.lisp,v 1.31 2006/03/06 16:09:12 crhodes Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -1042,6 +1042,11 @@ (t (make-instance 'standard-region-union :regions (list a b))))) +(defmethod region-intersection ((a point) (b point)) + (cond + ((region-equal a b) a) + (t +nowhere+))) + (defmethod region-equal ((a point) (b point)) (and (coordinate= (point-x a) (point-x b)) (coordinate= (point-y a) (point-y b)))) @@ -1316,8 +1321,8 @@ (defun isum-member (elt isum) (cond ((null isum) nil) - ((<= (car isum) elt (cadr isum)) t) - ((> elt (cadr isum)) nil) + ((< elt (car isum)) nil) + ((<= elt (cadr isum)) t) (t (isum-member elt (cddr isum))))) (defun rectangle->standard-rectangle-set (rect) @@ -1563,13 +1568,13 @@ (defmethod region-intersection ((b region) (a standard-polyline)) (region-intersection a b)) -(defmethod region-intersection ((a region) (p standard-point)) +(defmethod region-intersection ((a region) (p point)) (multiple-value-bind (x y) (point-position p) (if (region-contains-position-p a x y) p +nowhere+))) -(defmethod region-intersection ((p standard-point) (a region)) +(defmethod region-intersection ((p point) (a region)) (region-intersection a p)) (defmethod region-intersection ((a standard-region-union) (b region)) @@ -1656,7 +1661,7 @@ x) res)) -(defmethod region-difference ((x standard-point) (y region)) +(defmethod region-difference ((x point) (y region)) (multiple-value-bind (px py) (point-position x) (if (region-contains-position-p y px py) +nowhere+ @@ -2186,7 +2191,7 @@ (region-union (region-difference a b) (region-difference b a))) -(defmethod region-contains-region-p ((a region) (b standard-point)) +(defmethod region-contains-region-p ((a region) (b point)) (region-contains-position-p a (point-x b) (point-y b))) ;; xxx was ist mit (region-contains-region-p x +nowhere+) ?

1 0

[mcclim-cvs] CVS mcclim
by afuchs 03 Mar '06

03 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2565 Modified Files: recording.lisp mcclim.asd INSTALL.ASDF Log Message: Implement standard-tree-output-records using spatial trees. Also, document the updated installation process in INSTALL.ASDF. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/01/13 12:17:55 1.121 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/03 21:10:21 1.122 @@ -934,7 +934,6 @@ (defmethod map-over-output-records-1 (function (record standard-sequence-output-record) function-args) "Applies FUNCTION to all children in the order they were added." - (declare (ignore x-offset y-offset)) (if function-args (loop with children = (output-record-children record) for child across children @@ -972,10 +971,115 @@ when (region-intersects-region-p region child) do (apply function child function-args))) -;;; XXX bogus for now. -(defclass standard-tree-output-record (standard-sequence-output-record) - ( - )) + +;;; tree output recording + +(defclass tree-output-record-entry () + ((record :initarg :record :reader tree-output-record-entry-record) + (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle) + (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr))) + +(defun make-tree-output-record-entry (record inserted-nr) + (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr)) + +(defun %record-to-spatial-tree-rectangle (r) + (rectangles:make-rectangle + :lows `(,(bounding-rectangle-min-x r) + ,(bounding-rectangle-min-y r)) + :highs `(,(bounding-rectangle-max-x r) + ,(bounding-rectangle-max-y r)))) + +(defun %output-record-entry-to-spatial-tree-rectangle (r) + (when (null (tree-output-record-entry-cached-rectangle r)) + (let* ((record (tree-output-record-entry-record r))) + (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record)))) + (tree-output-record-entry-cached-rectangle r)) + +(defun %make-tree-output-record-tree () + (spatial-trees:make-spatial-tree :r + :rectfun #'%output-record-entry-to-spatial-tree-rectangle)) + +(defclass standard-tree-output-record (compound-output-record) + ((children :initform (%make-tree-output-record-tree) + :accessor %tree-record-children) + (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache) + (last-insertion-nr :initform 0 :accessor last-insertion-nr))) + +(defun %entry-in-children-cache (record entry) + (gethash entry (%tree-record-children-cache record))) + +(defun (setf %entry-in-children-cache) (new-val record entry) + (setf (gethash entry (%tree-record-children-cache record)) new-val)) + +(defmethod output-record-children ((record standard-tree-output-record)) + (map 'list + #'tree-output-record-entry-record + (spatial-trees:search (%record-to-spatial-tree-rectangle record) + (%tree-record-children record)))) + +(defmethod add-output-record (child (record standard-tree-output-record)) + (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) + (spatial-trees:insert entry (%tree-record-children record)) + (setf (output-record-parent child) record) + (setf (%entry-in-children-cache record child) entry))) + +(defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t)) + (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child) + (%tree-record-children record)) + :key #'tree-output-record-entry-record))) + (cond + ((not (null entry)) + (spatial-trees:delete entry (%tree-record-children record)) + (setf (%entry-in-children-cache record child) nil) + (setf (output-record-parent child) nil)) + (errorp (error "~S is not a child of ~S" child record))))) + +(defmethod clear-output-record ((record standard-tree-output-record)) + (dolist (child (output-record-children record)) + (setf (output-record-parent child) nil) + (setf (%entry-in-children-cache record child) nil)) + (setf (%tree-record-children record) (%make-tree-output-record-tree))) + +(defun map-over-tree-output-records (function record rectangle sort-order function-args) + (dolist (child (sort (spatial-trees:search rectangle + (%tree-record-children record)) + (ecase sort-order + (:most-recent-first #'>) + (:most-recent-last #'<)) + :key #'tree-output-record-entry-inserted-nr)) + (apply function (tree-output-record-entry-record child) function-args))) + +(defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args) + (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last + function-args)) + +(defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args) + (declare (ignore x-offset y-offset)) + (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first + function-args)) + +(defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args) + (declare (ignore x-offset y-offset)) + (typecase region + (everywhere-region (map-over-output-records-1 function record function-args)) + (nowhere-region nil) + (otherwise (map-over-tree-output-records + (lambda (child) + (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child)) + region) + (apply function child function-args))) + record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last + nil)))) + +(defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y) + (when (eql record (output-record-parent child)) + (let ((entry (%entry-in-children-cache record child))) + (spatial-trees:delete entry (%tree-record-children record)) + (setf (tree-output-record-entry-cached-rectangle entry) nil) + (spatial-trees:insert entry (%tree-record-children record)))) + (call-next-method)) + +;;; (defmethod match-output-records ((record t) &rest args) (apply #'match-output-records-1 record args)) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2005/08/19 21:34:41 1.6 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/03 21:10:21 1.7 @@ -63,9 +63,6 @@ :class requireable-system)) -(pushnew :clim *features*) -(pushnew :mcclim *features*) - (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module @@ -96,7 +93,7 @@ (:file "package" :depends-on ("Lisp-Dep")))) (defsystem :clim-core - :depends-on (:clim-lisp) + :depends-on (:clim-lisp :spatial-trees) :components ((:file "decls") (:module "Lisp-Dep" :depends-on ("decls") @@ -392,3 +389,7 @@ ;;; package dependency lists. (defsystem :mcclim :depends-on (:clim-looks)) + +(defmethod perform :after ((op load-op) (c (eql (find-system :mcclim)))) + (pushnew :clim *features*) + (pushnew :mcclim *features*)) \ No newline at end of file --- /project/mcclim/cvsroot/mcclim/INSTALL.ASDF 2005/03/06 19:57:12 1.2 +++ /project/mcclim/cvsroot/mcclim/INSTALL.ASDF 2006/03/03 21:10:21 1.3 @@ -16,15 +16,20 @@ have to load CLX via (require :clx) or a similar mechanism yourself. - 3. On your Lisp's REPL (with ASDF loaded), type + 3. You need to install the spatial-trees library (available at + http://cliki.net/spatial-trees) The preferred method for that is + via asdf-install. see http://cliki.net/asdf-install for an + introduction to that method. + + 4. On your Lisp's REPL (with ASDF loaded), type (asdf:oos 'asdf:load-op :mcclim) ; compilation messages should zip past -After step 3, McCLIM and a suitable backend should be loaded and +After step 4, McCLIM and a suitable backend should be loaded and you are good to go. -When you restart your lisp image, you will need to perform step 3 to +When you restart your lisp image, you will need to perform step 4 to load McCLIM again. Installing mcclim.asd if you were using ASDF & system.lisp before

1 0

[mcclim-cvs] CVS mcclim/Goatee
by afuchs 01 Mar '06

01 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv10392 Modified Files: clim-area.lisp Log Message: Add a bounding-rectangle* method for screen-line that takes a visible cursor at eol into account. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2005/02/22 14:00:18 1.31 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/03/01 21:51:54 1.32 @@ -196,8 +196,8 @@ &key (start 0) (end (length (current-contents line)))) (text-size (area-stream area) (current-contents line) - :start start - :end end)) + :start start + :end end)) (defmethod initialize-instance :after ((obj screen-line) &key (current-contents nil current-contents-p)) @@ -214,6 +214,18 @@ (values x1 y1 x2 (+ y1 (ascent obj) (descent obj)))) (setf (baseline obj) (+ y1 (ascent obj)))))) +(defmethod bounding-rectangle* ((record screen-line)) + (let ((cursor (cursor record))) + (multiple-value-bind (x1 y1 x2 y2) (call-next-method) + (values x1 y1 + (if cursor + (with-slots (climi::x climi::width) cursor + (max x2 (+ climi::x climi::width))) + x2) + (if cursor + (max y2 (+ y1 (climi::cursor-height cursor))) + y2))))) + (defmethod climi::map-over-output-records-1 (function (record screen-line) function-args) (declare (ignore function function-args))

1 0