Revision: 3681 Author: ksprotte URL: http://bknr.net/trac/changeset/3681
checkpoint U trunk/projects/bos/m2/contract-expiry.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/allocation.lisp U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/reports-xml-handler.lisp
Modified: trunk/projects/bos/m2/contract-expiry.lisp =================================================================== --- trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -1,7 +1,7 @@ (in-package :bos.m2)
(defun delete-expired-contracts () - (let ((unpaid-contracts (remove-if #'contract-paidp (class-instances 'contract))) + (let ((unpaid-contracts (remove-if #'contract-paidp (all-contracts))) deleting) (dolist (contract unpaid-contracts) (when (contract-is-expired contract)
Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/m2.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -257,7 +257,9 @@ (download-only :update) (cert-issued :read) (worldpay-trans-id :update :initform nil) - (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil) + (expires :read :documentation "universal time which specifies the + time the contract expires (is deleted) when it has not been paid for" + :initform nil) (largest-rectangle :update)) (:default-initargs :m2s nil @@ -379,7 +381,7 @@
(defun all-contracts () "Return list of all contracts in the system." - (class-instances 'all-contracts)) + (class-instances 'contract))
(defun contracts-bounding-box (&optional (contracts (all-contracts))) (geometry:with-bounding-box-collect (collect)
Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/packages.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -139,6 +139,7 @@
#:contract #:make-contract + #:all-contracts #:contract-p #:get-contract #:contract-sponsor
Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -28,20 +28,20 @@ (define-persistent-class poi-medium (textual-attributes-mixin) ((poi :read)))
-(deftransaction make-poi-medium (class-name &key language title subtitle description poi initargs) +(deftransaction make-poi-medium (class-name &rest rest &key language title subtitle description poi initargs) + (declare (ignore poi initargs)) (assert (if (or title subtitle description) language t) nil "language needs to be specified, if any of title, subtitle or description is given") - (let ((medium (apply #'make-object class-name :poi poi initargs))) - (update-textual-attributes medium language - :title title - :subtitle subtitle - :description description) - medium)) + (apply #'make-object class-name rest))
(defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) - (when (poi-medium-poi poi-medium) - (push poi-medium (poi-media (poi-medium-poi poi-medium))))) + (when poi + (push poi-medium (poi-media poi))) + (update-textual-attributes poi-medium language + :title title + :subtitle subtitle + :description description))
(defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) @@ -56,6 +56,14 @@ (define-persistent-class poi-image (store-image poi-medium) ())
+;;; poi-airal +(define-persistent-class poi-airal (store-image poi-medium) + ()) + +;;; poi-panorama +(define-persistent-class poi-panorama (store-image poi-medium) + ()) + ;;; poi-movie (define-persistent-class poi-movie (poi-medium) ((url :update :initform nil))) @@ -65,10 +73,10 @@ ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") + (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (media :update :initform nil))) + (icon :update :initform "palme" :documentation "Name des Icons") + (media :update :initform nil :documentation "Liste aller POI-Medien, wie POI-IMAGE, POI-AIRAL ...")))
(deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) @@ -76,12 +84,18 @@ (setf (slot-string poi 'description language) description) poi))
+(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description) + (update-textual-attributes poi language + :title title + :subtitle subtitle + :description description)) + (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi)))
(defmethod poi-complete ((poi poi) language) (and (every #'(lambda (slot-name) (slot-string poi slot-name language nil)) '(title subtitle description)) - (poi-area poi) + (poi-area poi) (<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi))) t))
@@ -94,6 +108,16 @@ (defun poi-center-lon-lat (poi) (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (poi-center-x poi)) (- +nw-utm-y+ (poi-center-y poi)) +utm-zone+ t))
+(macrolet ((define-poi-medium-reader (name) + (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name))))))) + (assert type) + `(defun ,name (poi) + (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))))) + (define-poi-medium-reader poi-images) + (define-poi-medium-reader poi-airals) + (define-poi-medium-reader poi-panoramas) + (define-poi-medium-reader poi-movies)) + (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) @@ -148,3 +172,19 @@ (format t "poi['y'] = ~D;~%" y) (format t "poi['thumbnail'] = 0;~%") (format t "pois.push(poi);~%"))))) + +;;; poi schema evolution aids + +(define-modify-macro appendf (&rest args) append) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'airals)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-airal :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'images)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-image :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'movies)) value) + (appendf (poi-media poi) (mapcar (lambda (url) (make-instance 'poi-movie :url url :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'panoramas)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-panorama :poi poi)) value)))
Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/test/allocation.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -83,7 +83,7 @@ (with-transaction () (iter (while (> size total-free)) - (for contract = (first (class-instances 'contract))) + (for contract = (first (all-contracts))) (incf total-free (length (contract-m2s contract))) (destroy-object contract))) (finishes (make-contract sponsor size))
Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -355,7 +355,7 @@ ;; has already been called :base-node *quad-tree* :name '*contract-tree*)) - (dolist (contract (class-instances 'contract)) + (dolist (contract (all-contracts)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*
Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -249,7 +249,7 @@ ())
(defmethod handle ((handler country-stats-handler)) - (let* ((contracts (class-instances 'contract)) + (let* ((contracts (all-contracts)) (timestamp (reduce #'max contracts :key (lambda (contract) (if (contract-paidp contract) (store-object-last-change contract 0)
Modified: trunk/projects/bos/web/reports-xml-handler.lisp =================================================================== --- trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -32,7 +32,7 @@ (or (not (contract-paidp contract)) (and *year* (not (eql *year* (contract-year contract)))))) - (class-instances 'contract)) + (all-contracts)) #'< :key #'contract-date))) (setf name (intern (string-upcase name) :bos.web)) (apply (or (gethash name *report-generators*)