Changeset 2847

Timestamp:

04/01/08 18:15:58 (8 months ago)

Author:

ksprotte

Message:

new functions for contract-tree

Files:

• trunk/projects/bos/tmp/contract-image-test.lisp (modified) (2 diffs)
• trunk/projects/bos/web/contract-tree.lisp (added)
• trunk/projects/bos/web/image-tree.lisp (modified) (1 diff)

trunk/projects/bos/tmp/contract-image-test.lisp

@@ -20 +20 @@
-
-(hunchentoot:define-easy-handler (ci :uri "/ci")
-
-
+
+
+
-    (geometry:with-rectangle rectangle
-      (with-image (image width height t)
@@ -28 +29 @@
-          (do-rows (y)
-            (do-pixels-in-row (x)
-
+
+
-                     (contract (and m2 (m2-contract m2))))          
-                (when (and contract (contract-paidp contract))                
-                  (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) (contract-color contract)))))))
-          (emit-image-to-browser image :png))))))
+
+(hunchentoot:define-easy-handler (ci2 :uri "/ci2")
+    ((size :init-form 256 :parameter-type 'integer)
+     (pixelize :init-form 1 :parameter-type 'integer))
+  (let ((rectangle '(6666 5467 571 426))        )
+    (geometry:with-rectangle rectangle
+      (let ((step (float (/ (max height width) size))))
+        (with-image (image size size t)
+          (with-default-image (image)        
+            (fill-image 0 0 :color (find-color 255 255 255))
+            (do-rows (y)
+              (do-pixels-in-row (x)
+                (let* ((m2 (get-m2 (+ left (round (* step (* pixelize (floor x pixelize)))))
+                                   (+ top (round (* step (* pixelize (floor y pixelize)))))))
+                       (contract (and m2 (m2-contract m2))))          
+                  (when (and contract (contract-paidp contract))                
+                    (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) (contract-color contract)))))))
+            (emit-image-to-browser image :png)))))))
-
-

trunk/projects/bos/web/image-tree.lisp

@@ -596 +596 @@
-
-
-
-(defclass image-tree-kml-handler (object-handler)
-  ()