[bknr-cvs] r2013 - branches/xml-class-rework/projects/bos/worldpay-test
bknr at bknr.net
bknr at bknr.net
Fri Oct 20 13:13:49 UTC 2006
Author: hhubner
Date: 2006-10-20 09:13:48 -0400 (Fri, 20 Oct 2006)
New Revision: 2013
Modified:
branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp
Log:
Read allocation area from plain text file with UTM coordinates.
Modified: branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp 2006-10-20 09:10:12 UTC (rev 2012)
+++ branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp 2006-10-20 13:13:48 UTC (rev 2013)
@@ -115,18 +115,14 @@
(t
90))
for source-x = (if (< tile-x left) (- 90 copy-width) 0)
- do (with-store-image (tile-image (image-tile-image (get-map-tile x y)))
- (cl-gd:copy-image tile-image
- cl-gd:*default-image*
- source-x source-y
- dest-x dest-y
- copy-width copy-height))
+ do (cl-gd:copy-image (image-tile-image (get-map-tile x y))
+ cl-gd:*default-image*
+ source-x source-y
+ dest-x dest-y
+ copy-width copy-height)
do (incf dest-x copy-width))
do (incf dest-y copy-height))
(cl-gd:draw-polygon vertices :color (elt colors 1))
- #+(or)
- (draw-contracts cl-gd:*default-image* left top width height colors
- (allocation-area-contracts allocation-area))
(emit-image-to-browser req cl-gd:*default-image* :png)))))
(defclass create-allocation-area-handler (admin-only-handler form-handler)
@@ -158,8 +154,8 @@
((:form :method "POST" :enctype "multipart/form-data"))
((:table :border "0")
(:tr ((:td :colspan "2")
- (:h2 "Create from Adobe Illustrator path")))
- (:tr (:td "File: ") (:td ((:input :type "file" :name "ai-file" :value "*.ai"))))
+ (:h2 "Create from list of UTM coordinates")))
+ (:tr (:td "File: ") (:td ((:input :type "file" :name "text-file" :value "*.txt"))))
(:tr (:td (submit-button "upload" "upload")))
(:tr ((:td :colspan "2")
(:h2 "Create by choosing rectangular area")))
@@ -176,42 +172,35 @@
req)))
(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req)
- (let ((uploaded-ai-file (cdr (find "ai-file" (request-uploaded-files req) :test #'equal :key #'car))))
+ (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car))))
(cond
- ((not uploaded-ai-file)
- (with-bos-cms-page (req :title "No Illustrator file uploaded")
+ ((not uploaded-text-file)
+ (with-bos-cms-page (req :title "No Text file uploaded")
(:h2 "File not uploaded")
- (:p "Please upload your Adobe Illustrator file containing the allocation polygon")))
+ (:p "Please upload your text file containing the allocation polygon UTM coordinates")))
(t
- (with-bos-cms-page (req :title #?"Importing allocation polygons from illustrator file $(uploaded-ai-file)")
+ (with-bos-cms-page (req :title #?"Importing allocation polygons from text file $(uploaded-text-file)")
(handler-case
- (loop for vertices in (polygons-from-illustrator-file uploaded-ai-file)
- for i from 1
- while vertices
- do (handler-case
- (let ((existing-area (find (coerce vertices 'list)
+ (let* ((vertices (polygon-from-text-file uploaded-text-file))
+ (existing-area (find (coerce vertices 'list)
(class-instances 'allocation-area)
:key #'(lambda (area) (coerce (allocation-area-vertices area) 'list))
:test #'equal)))
- (if existing-area
- (html (:p (:h2 "Polygon already imported")
- "The polygon " (:princ-safe vertices) " has already been "
- "imported as "
- (cmslink (format nil "allocation-area/~D" (store-object-id existing-area))
- "allocation area " (:princ-safe (store-object-id existing-area)))))
- (let ((allocation-area (make-allocation-area vertices)))
- (html (:p (:h2 "Successfully imported polygon number " (:princ-safe i))
- "The polygon "
- (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area))
- (:princ-safe (store-object-id allocation-area)))
- " has been successfully imported")))))
- (error (e)
- (html (:p (:h2 "Error importing polygon number " (:princ-safe i))
- "The polygon " (:princ-safe vertices) " could not be imported"
- (:pre (:princ-safe e)))))))
+ (if existing-area
+ (html (:p (:h2 "Polygon already imported")
+ "The polygon " (:princ-safe vertices) " has already been "
+ "imported as "
+ (cmslink (format nil "allocation-area/~D" (store-object-id existing-area))
+ "allocation area " (:princ-safe (store-object-id existing-area)))))
+ (let ((allocation-area (make-allocation-area vertices)))
+ (html (:p (:h2 "Successfully imported new allocation area")
+ "The polygon "
+ (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area))
+ (:princ-safe (store-object-id allocation-area)))
+ " has been successfully imported")))))
(error (e)
(html
- (:h2 "Error reading the Illustrator file")
+ (:h2 "Error reading the text file")
(:p "Please make sure that the uploaded file only contains a simple path.")
(:p "The error encountered is:")
(:pre (:princ-safe e))))))))))
@@ -226,6 +215,35 @@
(error (e)
(error "error ~A on file ~A while waiting for ~A" e file regex))))
+(defun ensure-float (x)
+ (typecase x
+ (float t)
+ (integer t)
+ (t (error "invalid number ~S" x))))
+
+(defun scale-coordinate (name min x)
+ (unless (and (>= x min)
+ (<= x (+ min +width+)))
+ (error "invalid ~A coordinate ~A (must be between ~A and ~A)" name x min (+ min +width+)))
+ (round (- x min)))
+
+(defun parse-point (line)
+ (destructuring-bind (x y) (read-from-string (format nil "(~A)" line))
+ (cons (scale-coordinate 'x +nw-utm-x+ x)
+ (scale-coordinate 'y +nw-utm-y+ y))))
+
+(defun polygon-from-text-file (filename)
+ (coerce (with-open-file (input-file filename)
+ (loop
+ for line-number from 1
+ for line = (read-line input-file nil)
+ while line
+ collect (handler-case
+ (parse-point line)
+ (error (e)
+ (error "~A in line ~A" e line-number)))))
+ 'vector))
+
(defun parse-illustrator-point (line)
(destructuring-bind (x y type &rest foo) (split " " line)
(declare (ignore foo))
More information about the Bknr-cvs
mailing list