Changeset 3220

Show
Ignore:
Timestamp:
05/30/08 15:01:10 (7 months ago)
Author:
ksprotte
Message:

branches/bos-trunk-sat: persistence and delete-object now implemented for sat-layer and related classes

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/bos-trunk-sat/projects/bos/web/quad-tree.lisp

    r3216 r3220  
    181181    (format stream "name: ~s path: ~s" (name node) (node-path node)))) 
    182182 
     183(defmethod delete-node-extension ((node node-extension))   
     184  (setf (%extensions (base-node node)) 
     185        (delete node (%extensions (base-node node))))) 
     186 
    183187(defun equal-extension-type (a b) 
    184188  (and (eql (type-of a) 

  • branches/bos-trunk-sat/projects/bos/web/sat-tree.lisp

    r3219 r3220  
    22 
    33(defclass sat-node (node-extension) 
    4   ((image :accessor image :initarg :image :type store-image))) 
     4  ((image :accessor image :initarg :image))) 
     5 
     6(defmethod delete-node-extension :before ((obj sat-node)) 
     7  (delete-object (image obj))) 
    58 
    69(defpersistent-class sat-layer () 
    …… 
    912         :index-reader find-sat-layer) 
    1013   (geo-box :reader geo-box :initarg :geo-box))) 
     14 
     15(defmethod print-object ((obj sat-layer) stream) 
     16  (print-unreadable-object (obj stream :type t :identity t) 
     17    (format stream "name: ~s" (name obj)))) 
     18 
     19(defmethod destroy-object :before ((obj sat-layer)) 
     20  (dolist (top-level-node (sat-layer-top-level-nodes obj)) 
     21    (delete-node-extension top-level-node))) 
    1122 
    1223(defun sat-layer-top-level-nodes (sat-layer)   
    …… 
    3748(defpersistent-class sat-image (store-image) 
    3849  ((layer :reader layer :initarg :layer) 
    39    (node :reader node :initarg :node :transient t) 
     50   (node :reader node :initarg :node :transient t)    
    4051   (path :reader path :initarg :path) 
    4152   (image-geo-box :accessor image-geo-box 
    …… 
    4657(defmethod print-object ((obj sat-image) stream) 
    4758  (print-unreadable-object (obj stream :type t :identity t))) 
     59 
     60(defmethod initialize-transient-instance :after ((sat-image sat-image)) 
     61  (let ((node (ensure-node-with-path *quad-tree* (path sat-image)))) 
     62    (make-instance 'sat-node 
     63                   :name (name (layer sat-image)) 
     64                   :base-node node 
     65                   :image sat-image))) 
    4866 
    4967(defmethod name ((obj sat-image)) 
    …… 
    88106 
    89107(defun make-sat-image-tile (image geo-box quad-node tile-geo-box name max-scaling) 
     108  (assert (find-sat-layer name)) 
    90109  (multiple-value-bind (scaling 
    91110                        pw ph px py px2 py2 
    …… 
    100119                          :resize t :resample t 
    101120                          :dest-width tw :dest-height th) 
    102         (make-instance 'sat-node 
    103                        :name name 
    104                        :base-node quad-node 
    105                        :image (make-store-image :class-name 'sat-image 
    106                                                 :name (format nil "~A-~{~D~}" name path) 
    107                                                 :initargs `(:path ,path 
    108                                                                   :image-geo-box ,rounded-geo-box))))))) 
     121        (make-store-image :class-name 'sat-image 
     122                          :name (format nil "~A-~{~D~}" name path) 
     123                          :initargs `(:path ,path 
     124                                            :layer ,(find-sat-layer name) 
     125                                            :image-geo-box ,rounded-geo-box)))))) 
    109126 
    110127(defun make-sat-layer (image geo-box name &optional (start-depth 0)) 
    …… 
    138155    (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 
    139156           (max-scaling (max-scaling nodes))) 
     157      (make-object 'sat-layer :name name :geo-box geo-box) 
    140158      (dolist (node nodes) 
    141159        (make-sat-image-tile image geo-box (quad-node node) 
    142                              (tile-geo-box node) name max-scaling))) 
    143     (make-object 'sat-layer :name name :geo-box geo-box))) 
     160                             (tile-geo-box node) name max-scaling))))) 
    144161 
    145162;; (with-store-image (image (first (class-instances 'store-image)))