sat-tree.lisp

Revision 3942, 12.3 kB (checked in by hans, 2 months ago)
Merge from anon-transaction-fixes-2 branch. This changeset removes make-object and initialize-persistent-instance, makes the allocation of object IDs simpler and more safe and removes several relicts from previous refactoring iterations. Also, the store tests have been extended significantly to test pathological cases and create objects from multiple threads.

Line
1	(in-package :bos.web)
2
3	(defclass sat-node (node-extension)
4	((image :accessor image :initarg :image)))
5
6	(defpersistent-class sat-layer ()
7	((name :reader name :initarg :name
8	:index-type unique-index
9	:index-reader find-sat-layer)
10	(year :accessor year :initarg :year :initform 2000)
11	(geo-box :reader geo-box :initarg :geo-box)
12	(local-draw-order :reader local-draw-order :initarg :local-draw-order)))
13
14	(defmethod print-object ((obj sat-layer) stream)
15	(print-unreadable-object (obj stream :type t :identity t)
16	(format stream "name: ~s" (name obj))))
17
18	(defmethod destroy-object :before ((obj sat-layer))
19	(when (boundp 'quad-tree)
20	;; when the transaction log is being loaded, quad-tree is still
21	;; unbound, because it is only initialized, when the entire store
22	;; has been loaded -- an example for the fact that the quad-tree
23	;; should have been implemented as a proper store index
24	(assert (null (sat-layer-top-level-nodes obj)) nil
25	"Please invoke (remove-sat-layer-from-quad-tree (find-store-object ~D)) before deleting ~s."
26	(store-object-id obj) obj))
27	(dolist (sat-image (class-instances 'sat-image))
28	(when (eq obj (layer sat-image))
29	(delete-object sat-image))))
30
31	(defun remove-sat-layer-from-quad-tree (sat-layer)
32	(let ((nodes (collect-nodes (constantly t) (first (sat-layer-top-level-nodes sat-layer)))))
33	(mapc #'delete-node-extension nodes)
34	(values)))
35
36	(defun sat-layer-top-level-nodes (sat-layer)
37	(check-type sat-layer sat-layer)
38	(let ((nodes ())
39	top-level-depth
40	(state 'no-layer-node))
41	(block collect
42	(map-nodes (lambda (n)
43	(let ((layer-node (find-if (lambda (e) (and (eql (name e) (name sat-layer))
44	(typep e 'sat-node)))
45	(extensions n))))
46	(ecase state
47	(no-layer-node
48	(when layer-node
49	(push layer-node nodes)
50	(setq state 'got-top-level-layer-node)
51	(setq top-level-depth (depth n))))
52	(got-top-level-layer-node
53	(if (and layer-node (= (depth n) top-level-depth))
54	(push layer-node nodes)
55	(return-from collect))))))
56	quad-tree
57	:prune-test (lambda (n) (not (geo-box-intersect-p (geo-box n) (geo-box sat-layer))))
58	:order :breadth-first))
59	(nreverse nodes)))
60
61	(defpersistent-class sat-image (store-image)
62	((layer :reader layer :initarg :layer)
63	(path :reader path :initarg :path)
64	(image-geo-box :accessor image-geo-box
65	:initarg :image-geo-box
66	:type geo-box
67	:documentation "can be different from base-node's geo-box")))
68
69	(defmethod print-object ((obj sat-image) stream)
70	(print-unreadable-object (obj stream :type t :identity t)
71	(format stream "~s of layer ~s" (path obj) (name (layer obj)))))
72
73	(defun quad-tree-insert-sat-image (sat-image)
74	(let ((node (ensure-node-with-path quad-tree (path sat-image))))
75	(make-instance 'sat-node
76	:name (name (layer sat-image))
77	:base-node node
78	:image sat-image)))
79
80	(defun quad-tree-insert-sat-images ()
81	(mapc #'quad-tree-insert-sat-image (class-instances 'sat-image)))
82
83	(register-transient-init-function 'quad-tree-insert-sat-images
84	'make-quad-tree)
85
86	(defmethod name ((obj sat-image))
87	(name (layer obj)))
88
89	(defconstant +max-sat-image-tile-pixel-area+ (float (expt 256 2) 0d0))
90
91	(defun sat-image-tile-properties (image geo-box tile-geo-box &optional scaling)
92	#+nil(declare (optimize speed))
93	;; (the (double-float 0d0 #.(float most-positive-fixnum 0d0)) ...)
94	;; might be useful
95	(let* ((gw (float (the (integer 1 #.most-positive-fixnum) (cl-gd:image-width image)) 0d0))
96	(gh (float (the (integer 1 #.most-positive-fixnum) (cl-gd:image-height image)) 0d0))
97	(w (geo-box-west geo-box))
98	(n (geo-box-north geo-box))
99	(e (geo-box-east geo-box))
100	(s (geo-box-south geo-box))
101	(bw (geo-box-west tile-geo-box))
102	(bn (geo-box-north tile-geo-box))
103	(be (geo-box-east tile-geo-box))
104	(bs (geo-box-south tile-geo-box))
105	(xu (/ (- e w) gw))
106	(yu (/ (- n s) gh))
107	(px (floor (/ (- bw w) xu)))
108	(py (floor (/ (- n bn) yu)))
109	(px2 (ceiling (/ (- be w) xu)))
110	(py2 (ceiling (/ (- n bs) yu)))
111	(pw (- px2 px))
112	(ph (- py2 py))
113	(rounded-geo-box (make-geo-box (+ (* px xu) w)
114	(- n (* py yu))
115	(+ (* px2 xu) w)
116	(- n (* py2 yu))))
117	(scaling (if scaling
118	scaling
119	(ceiling (sqrt (/ (* pw ph) +max-sat-image-tile-pixel-area+)))))
120	(tw (round (/ pw scaling)))
121	(th (round (/ ph scaling))))
122	(values scaling
123	pw ph px py px2 py2
124	tw th rounded-geo-box)))
125
126	(defun make-sat-image-tile (image geo-box quad-node tile-geo-box name max-scaling)
127	(assert (find-sat-layer name))
128	(multiple-value-bind (scaling
129	pw ph px py px2 py2
130	tw th rounded-geo-box)
131	(sat-image-tile-properties image geo-box tile-geo-box max-scaling)
132	(declare (ignore scaling px2 py2))
133	(let ((path (node-path quad-node)))
134	(cl-gd:with-image (cl-gd:default-image tw th t)
135	(cl-gd:copy-image image cl-gd:default-image
136	px py 0 0
137	pw ph
138	:resize t :resample t
139	:dest-width tw :dest-height th)
140	(quad-tree-insert-sat-image
141	(make-store-image :class-name 'sat-image
142	:name (format nil "~A-~{~D~}" name path)
143	:type :jpg
144	:initargs `(:path ,path
145	:layer ,(find-sat-layer name)
146	:image-geo-box ,rounded-geo-box)))))))
147
148	(defun make-sat-image-tiles-for-depth (image geo-box layer start-depth)
149	(labels ((layer-quad-nodes ()
150	(let (nodes)
151	(ensure-intersecting-children quad-tree geo-box
152	(lambda (n) (when (= start-depth (depth n))
153	(push n nodes)))
154	(lambda (n) (= start-depth (depth n))))
155	(mapcar
156	(lambda (quad-node)
157	(list quad-node (geo-box-intersection geo-box (geo-box quad-node))))
158	nodes)))
159	(quad-node (node) (first node))
160	(tile-geo-box (node) (second node))
161	(pw-ph-large-enough (node)
162	(multiple-value-bind (scaling pw ph)
163	(sat-image-tile-properties image geo-box (tile-geo-box node))
164	(declare (ignore scaling))
165	(and (> pw 1) (> ph 1))))
166	(max-scaling (nodes)
167	(reduce #'max nodes
168	:key (lambda (node)
169	(sat-image-tile-properties image geo-box (tile-geo-box node))))))
170	(let* ((name (name layer))
171	(nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes)))
172	(max-scaling (max-scaling nodes)))
173	(format t "; creating ~a at depth ~a~%" name start-depth) ;
174	(dolist (node nodes layer)
175	(make-sat-image-tile image geo-box (quad-node node)
176	(tile-geo-box node) name max-scaling))
177	(unless (= 1 max-scaling)
178	(make-sat-image-tiles-for-depth image geo-box layer (1+ start-depth))))))
179
180	(defun make-sat-layer (image geo-box name local-draw-order &optional (start-depth 0))
181	(check-type name symbol)
182	(assert (not (find-sat-layer name)) (name)
183	"A sat-layer of name ~S already exists." name)
184	(check-type image cl-gd::image)
185	(assert (geo-box-encloses-p m2-geo-box geo-box))
186	(check-type start-depth (integer 0))
187	(check-type local-draw-order (integer 0))
188	;; highest local-draw-order is reserved for the contract-tree
189	(assert (< local-draw-order (1- +max-num-of-local-draw-order-levels+)))
190	(when (find local-draw-order (class-instances 'sat-layer) :key #'local-draw-order)
191	(cerror "create the new layer anyway" "There is already a sat-layer with the same local-draw-order '~A'." local-draw-order))
192	(let ((layer (make-instance 'sat-layer :name name :geo-box geo-box :local-draw-order local-draw-order)))
193	(make-sat-image-tiles-for-depth image geo-box layer start-depth)
194	layer))
195
196	;; (with-store-image (image (first (class-instances 'store-image)))
197	;; (make-sat-layer image
198	;; (rectangle-geo-box (make-rectangle :x 5400 :y 5400 :width 2000 :height 2000))
199	;; :sat1
200	;; 3))
201
202
203	;;; handlers
204
205	(defclass sat-tree-kml-handler (page-handler)
206	())
207
208	(defmethod handle ((handler sat-tree-kml-handler))
209	(with-query-params ((path) (name))
210	(let ((path (parse-path path))
211	(layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD")))))
212	(assert layer nil "Cannnot find layer of name ~s." name)
213	(let* ((quad-node (find-node-with-path quad-tree path))
214	(sat-node (find-if (lambda (e) (and (eql (name e) (name layer))
215	(typep e 'sat-node)))
216	(extensions quad-node))))
217	(assert sat-node nil "There is no sat-node of name ~s at path ~s." name path)
218	(let ((sat-image (image sat-node)))
219	(hunchentoot:handle-if-modified-since (blob-timestamp sat-image))
220	(with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
221	:root-element "kml")
222	(setf (hunchentoot:header-out :last-modified)
223	(hunchentoot:rfc-1123-date (blob-timestamp sat-image)))
224	(let ((lod (node-lod sat-node))
225	(rect (geo-box-rectangle (geo-box sat-node))))
226	(with-element "Document"
227	(kml-region rect lod)
228	(kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image))
229	(geo-box-rectangle (image-geo-box sat-image))
230	:draw-order (compute-draw-order sat-node (local-draw-order layer))
231	;; :absolute 0
232	)
233	(let ((print-case :downcase))
234	(dotimes (i 4)
235	(let ((child (child sat-node i)))
236	(when child
237	(kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}"
238	(website-host) (name layer) (append path (list i)))
239	:rect (geo-box-rectangle (geo-box child))
240	:lod (node-lod child))))))))))))))
241
242	(defclass sat-root-kml-handler (page-handler)
243	())
244
245	(defmethod handle ((handler sat-root-kml-handler))
246	(with-query-params ((name))
247	(let ((print-case :downcase)
248	(layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD")))))
249	(assert layer nil "Cannnot find layer of name ~s." name)
250	(let ((top-level-nodes (sat-layer-top-level-nodes layer)))
251	(assert top-level-nodes)
252	(hunchentoot:handle-if-modified-since (blob-timestamp (image (first top-level-nodes))))
253	(with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
254	:root-element "kml")
255	(setf (hunchentoot:header-out :last-modified)
256	(hunchentoot:rfc-1123-date (blob-timestamp (image (first top-level-nodes)))))
257	(with-element "Document"
258	(dolist (node top-level-nodes)
259	(kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}"
260	(website-host) (name layer) (node-path node))
261	:rect (geo-box-rectangle (geo-box node))
262	:lod (node-lod node)))))))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format