[bknr-cvs] ksprotte changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Thu Jul 31 08:54:27 UTC 2008
Revision: 3706
Author: ksprotte
URL: http://bknr.net/trac/changeset/3706
added reader poi-sat-images and transaction poi-sat-images-exchange-neighbours for edit-poi handler
U trunk/projects/bos/m2/packages.lisp
U trunk/projects/bos/m2/poi.lisp
U trunk/projects/bos/web/poi-handlers.lisp
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp 2008-07-31 08:21:43 UTC (rev 3705)
+++ trunk/projects/bos/m2/packages.lisp 2008-07-31 08:54:27 UTC (rev 3706)
@@ -229,6 +229,8 @@
#:poi-center-y
#:poi-center-lon-lat
#:poi-images
+ #:poi-sat-images
+ #:poi-sat-images-exchange-neighbours
#:poi-airals
#:poi-panoramas
#:poi-movies
Modified: trunk/projects/bos/m2/poi.lisp
===================================================================
--- trunk/projects/bos/m2/poi.lisp 2008-07-31 08:21:43 UTC (rev 3705)
+++ trunk/projects/bos/m2/poi.lisp 2008-07-31 08:54:27 UTC (rev 3706)
@@ -117,16 +117,46 @@
(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))
+;;; POI media are stored in one list - for convenience we provide
+;;; accessors by type. POI-IMAGES e.g. returns a list of all
+;;; POI-IMAGES in the same order as they appear in the media list. The
+;;; second value is a list of corresponding positions in that list.
(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))))))
+ ;; this surely could be optimized
+ (let ((media-of-type (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi))))
+ (values media-of-type
+ (mapcar (lambda (medium) (position medium (poi-media poi))) media-of-type)))))))
(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 poi-sat-images (poi)
+ "We use the 6 last (oldest) images of POI as images for the
+ satellite application."
+ (multiple-value-bind (images positions)
+ (poi-images poi)
+ (let* ((length (length images))
+ (start (max 0 (- length 6))))
+ (values (subseq images start length)
+ (subseq positions start length)))))
+
+;;; Provides for the shifting of images in the edit-poi handler.
+;;; Exchanges (nth index (poi-sat-images poi)) with
+;;; (nth (1+ index) (poi-sat-images poi)).
+(deftransaction poi-sat-images-exchange-neighbours (poi index)
+ (check-type index (integer 0 4))
+ (multiple-value-bind (images positions)
+ (poi-images poi)
+ (declare (ignore images))
+ (let ((media-index-a (nth index positions))
+ (media-index-b (nth (1+ index) positions)))
+ (rotatef (nth media-index-a (poi-media poi))
+ (nth media-index-b (poi-media poi))))))
+
(defun make-poi-javascript (language)
"Erzeugt das POI-Javascript für das Infosystem"
(with-output-to-string (*standard-output*)
@@ -155,8 +185,8 @@
(escape-nl (slot-string poi 'description language))
(poi-center-x poi)
(poi-center-y poi)
- (length (poi-images poi)))
- (format t "poi.thumbnail = ~D;~%" (length (poi-images poi)))
+ (length (poi-sat-images poi)))
+ (format t "poi.thumbnail = ~D;~%" (length (poi-sat-images poi)))
(when (poi-airals poi)
(format t "poi.luftbild = ~D;~%" (store-object-id (first (poi-airals poi)))))
@@ -168,7 +198,7 @@
for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext")
for slot-values = (mapcar (lambda (image)
(escape-nl (slot-string image slot-name language)))
- (poi-images poi))
+ (poi-sat-images poi))
when slot-values
do (format t "poi.~A = [ ~{~S~^, ~} ];~%" javascript-name slot-values))
(format t "pois.push(poi);~%"))
Modified: trunk/projects/bos/web/poi-handlers.lisp
===================================================================
--- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:21:43 UTC (rev 3705)
+++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:54:27 UTC (rev 3706)
@@ -56,15 +56,15 @@
;; change image order
(setq shift (find-store-object (parse-integer shift)))
(setq shift-by (parse-integer shift-by))
- (let* ((new-images (poi-images poi))
+ (let* ((new-images (poi-sat-images poi))
(old-position (position shift new-images))
(tmp (nth old-position new-images)))
(assert (and (< -1 old-position (length new-images))
(< -1 (+ shift-by old-position) (length new-images))))
(setf (nth old-position new-images) (nth (+ shift-by old-position) new-images))
(setf (nth (+ shift-by old-position) new-images) tmp)
- (with-transaction ("setf poi-images")
- (setf (poi-images poi) new-images))))
+ (with-transaction ("setf poi-sat-images")
+ (setf (poi-sat-images poi) new-images))))
(with-bos-cms-page (:title "Edit POI")
(content-language-chooser)
(unless (poi-complete poi language)
@@ -107,24 +107,24 @@
(:td
((:table)
(:tr
- (loop for image in (poi-images poi)
+ (loop for image in (poi-sat-images poi)
for index from 1 by 1
do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi)))
((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image)))))
- :br
- (if (eql index 1)
- (html ((:img :src "/images/trans.gif" :width "16")))
- (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1"
- (store-object-id poi)
- (store-object-id image)))
- ((:img :border "0" :src "/images/pfeil-l.gif")))))
- ((:img :src "/images/trans.gif" :width "23"))
- (unless (eql index (length (poi-images poi)))
- (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1"
- (store-object-id poi)
- (store-object-id image)))
- ((:img :border "0" :src "/images/pfeil-r.gif"))))))))))
- (unless (eql 6 (length (poi-images poi)))
+ :br
+ (if (eql index 1)
+ (html ((:img :src "/images/trans.gif" :width "16")))
+ (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1"
+ (store-object-id poi)
+ (store-object-id image)))
+ ((:img :border "0" :src "/images/pfeil-l.gif")))))
+ ((:img :src "/images/trans.gif" :width "23"))
+ (unless (eql index (length (poi-sat-images poi)))
+ (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1"
+ (store-object-id poi)
+ (store-object-id image)))
+ ((:img :border "0" :src "/images/pfeil-r.gif"))))))))))
+ (unless (eql 6 (length (poi-sat-images poi)))
(html
:br
(cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]")))))
@@ -342,8 +342,8 @@
(:td ((:img :src (format nil "/image/~A" (store-object-id poi-image))))))
(:tr (:td "upload new image")
(:td ((:input :type "file" :name "image-file"))
- :br
- (submit-button "upload" "upload")))
+ :br
+ (submit-button "upload" "upload")))
(:tr (:td "title")
(:td (text-field "title"
:value (slot-string poi-image 'title language))))
@@ -416,9 +416,9 @@
(declare (ignore poi-name))
(let ((image-index (1- (parse-integer image-index-string))))
(if (and (not (minusp image-index))
- (< image-index (length (poi-images poi))))
+ (< image-index (length (poi-sat-images poi))))
(redirect (format nil "/image/~D~@[~{/~a~}~]"
- (store-object-id (nth image-index (poi-images poi)))
+ (store-object-id (nth image-index (poi-sat-images poi)))
imageproc-arguments))
(error "image index ~a out of bounds for poi ~a" image-index poi)))))
@@ -436,8 +436,8 @@
((:param :name "movie" :value (poi-movie-url poi-movie)))
((:param :name "allowFullScreen" :value "true"))
((:embed :src (poi-movie-url poi-movie) :type "application/x-shockwave-flash"
- :allowFullScreen "true"
- :width "425" :height "344")))))
+ :allowFullScreen "true"
+ :width "425" :height "344")))))
(defun write-poi-xml (poi language)
"Writes the poi xml format for one specific language. This is used
@@ -467,7 +467,7 @@
(subtitle poi-subtitle)
(description poi-description)
(airals poi-airals)
- (images poi-images)
+ (images poi-sat-images)
(panoramas poi-panoramas)
(movies poi-movies)) poi
(with-element "poi"
@@ -564,7 +564,7 @@
(with-element "br")))
(with-element "table"
(with-element "tbody"
- (let ((images (poi-images poi)))
+ (let ((images (poi-sat-images poi)))
(images-2trs (subseq images 0 (min 3 (length images))))
(when (> (length images) 3)
(images-2trs (subseq images 3 (min 6 (length images))))))))))
More information about the Bknr-cvs
mailing list