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