/[mcclim]/mcclim/recording.lisp
ViewVC logotype

Diff of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.121 by cfruhwirth, Fri Jan 13 12:17:55 2006 UTC revision 1.122 by afuchs, Fri Mar 3 21:10:21 2006 UTC
# Line 934  the associated sheet can be determined." Line 934  the associated sheet can be determined."
934  (defmethod map-over-output-records-1  (defmethod map-over-output-records-1
935      (function (record standard-sequence-output-record) function-args)      (function (record standard-sequence-output-record) function-args)
936    "Applies FUNCTION to all children in the order they were added."    "Applies FUNCTION to all children in the order they were added."
   (declare (ignore x-offset y-offset))  
937    (if function-args    (if function-args
938        (loop with children = (output-record-children record)        (loop with children = (output-record-children record)
939           for child across children           for child across children
# Line 972  were added." Line 971  were added."
971       when (region-intersects-region-p region child)       when (region-intersects-region-p region child)
972       do (apply function child function-args)))       do (apply function child function-args)))
973    
974  ;;; XXX bogus for now.  
975  (defclass standard-tree-output-record (standard-sequence-output-record)  ;;; tree output recording
976    (  
977     ))  (defclass tree-output-record-entry ()
978         ((record :initarg :record :reader tree-output-record-entry-record)
979          (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle)
980          (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr)))
981    
982    (defun make-tree-output-record-entry (record inserted-nr)
983      (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr))
984    
985    (defun %record-to-spatial-tree-rectangle (r)
986      (rectangles:make-rectangle
987       :lows `(,(bounding-rectangle-min-x r)
988                ,(bounding-rectangle-min-y r))
989       :highs `(,(bounding-rectangle-max-x r)
990                 ,(bounding-rectangle-max-y r))))
991    
992    (defun %output-record-entry-to-spatial-tree-rectangle (r)
993      (when (null (tree-output-record-entry-cached-rectangle r))
994        (let* ((record (tree-output-record-entry-record r)))
995          (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record))))
996      (tree-output-record-entry-cached-rectangle r))
997    
998    (defun %make-tree-output-record-tree ()
999      (spatial-trees:make-spatial-tree :r
1000                            :rectfun #'%output-record-entry-to-spatial-tree-rectangle))
1001    
1002    (defclass standard-tree-output-record (compound-output-record)
1003      ((children :initform (%make-tree-output-record-tree)
1004                 :accessor %tree-record-children)
1005       (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache)
1006       (last-insertion-nr :initform 0 :accessor last-insertion-nr)))
1007    
1008    (defun %entry-in-children-cache (record entry)
1009      (gethash entry (%tree-record-children-cache record)))
1010    
1011    (defun (setf %entry-in-children-cache) (new-val record entry)
1012      (setf (gethash entry (%tree-record-children-cache record)) new-val))
1013    
1014    (defmethod output-record-children ((record standard-tree-output-record))
1015      (map 'list
1016           #'tree-output-record-entry-record
1017           (spatial-trees:search (%record-to-spatial-tree-rectangle record)
1018                                 (%tree-record-children record))))
1019    
1020    (defmethod add-output-record (child (record standard-tree-output-record))
1021      (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
1022        (spatial-trees:insert entry (%tree-record-children record))
1023        (setf (output-record-parent child) record)
1024        (setf (%entry-in-children-cache record child) entry)))
1025    
1026    (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t))
1027      (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child)
1028                                                     (%tree-record-children record))
1029                         :key #'tree-output-record-entry-record)))
1030       (cond
1031         ((not (null entry))
1032          (spatial-trees:delete entry (%tree-record-children record))
1033          (setf (%entry-in-children-cache record child) nil)
1034          (setf (output-record-parent child) nil))
1035         (errorp (error "~S is not a child of ~S" child record)))))
1036    
1037    (defmethod clear-output-record ((record standard-tree-output-record))
1038      (dolist (child (output-record-children record))
1039        (setf (output-record-parent child) nil)
1040        (setf (%entry-in-children-cache record child) nil))
1041      (setf (%tree-record-children record) (%make-tree-output-record-tree)))
1042    
1043    (defun map-over-tree-output-records (function record rectangle sort-order function-args)
1044      (dolist (child (sort (spatial-trees:search rectangle
1045                                                 (%tree-record-children record))
1046                           (ecase sort-order
1047                             (:most-recent-first #'>)
1048                             (:most-recent-last #'<))
1049                           :key #'tree-output-record-entry-inserted-nr))
1050        (apply function (tree-output-record-entry-record child) function-args)))
1051    
1052    (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args)
1053      (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last
1054                                    function-args))
1055    
1056    (defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args)
1057      (declare (ignore x-offset y-offset))
1058      (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
1059                                    function-args))
1060    
1061    (defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args)
1062      (declare (ignore x-offset y-offset))
1063      (typecase region
1064        (everywhere-region (map-over-output-records-1 function record function-args))
1065        (nowhere-region nil)
1066        (otherwise (map-over-tree-output-records
1067                    (lambda (child)
1068                      (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child))
1069                                                         region)
1070                           (apply function child function-args)))
1071                    record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last
1072                    nil))))
1073    
1074    (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)
1075      (when (eql record (output-record-parent child))
1076        (let ((entry (%entry-in-children-cache record child)))
1077         (spatial-trees:delete entry (%tree-record-children record))
1078         (setf (tree-output-record-entry-cached-rectangle entry) nil)
1079         (spatial-trees:insert entry (%tree-record-children record))))
1080      (call-next-method))
1081    
1082    ;;;
1083    
1084  (defmethod match-output-records ((record t) &rest args)  (defmethod match-output-records ((record t) &rest args)
1085    (apply #'match-output-records-1 record args))    (apply #'match-output-records-1 record args))

Legend:
Removed from v.1.121  
changed lines
  Added in v.1.122

  ViewVC Help
Powered by ViewVC 1.1.5