[mcclim-cvs] CVS mcclim
afuchs
afuchs at common-lisp.net
Fri Mar 3 21:10:21 UTC 2006
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
More information about the Mcclim-cvs
mailing list