Changeset 2846

Show
Ignore:
Timestamp:
04/01/08 14:19:16 (9 months ago)
Author:
ksprotte
Message:

new functions for allocation-areas-bounding-box

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/m2/allocation.lisp

    r2810 r2846  
    168168                                 'vector))) 
    169169    bounding-box)) 
     170 
     171(defmethod allocation-area-bounding-box2 ((allocation-area allocation-area)) 
     172  "Returns the bounding-box in a standard rectangle representation." 
     173  (with-slots (left top width height) allocation-area 
     174    (list left top width height))) 
     175 
     176(defun allocation-areas-bounding-box (&optional (allocation-areas (class-instances 'allocation-area))) 
     177  (geometry:with-bounding-box-collect (collect) 
     178    (dolist (area allocation-areas) 
     179      (geometry:with-rectangle ((allocation-area-bounding-box2 area)) 
     180        (collect (list left top)) 
     181        (collect (list (1- (+ left width)) (1- (+ top height)))))))) 
    170182 
    171183(defun gauge (area) 

  • trunk/projects/bos/m2/geometry.lisp

    r2838 r2846  
    2121           ,@body)))) 
    2222 
    23 (defmacro with-rectangle (rectangle &body body) 
    24   (destructuring-bind (rectangle &key suffix) (ensure-list rectangle) 
     23(defmacro with-rectangle (rectangle-or-options &body body) 
     24  (destructuring-bind (rectangle &key suffix) (ensure-list rectangle-or-options) 
    2525    (flet ((add-suffix (symbol) 
    2626             (if suffix 
    27                  (intern (format nil "~a-~a" (symbol-name symbol) (string-upcase suffix)) 
    28                          (symbol-package rectangle)) 
    29                  (intern (symbol-name symbol) (symbol-package rectangle))))) 
     27                 (intern (format nil "~a-~a" (symbol-name symbol) (string-upcase suffix))) 
     28                 (intern (symbol-name symbol))))) 
    3029      `(destructuring-bind (,(add-suffix 'left) 
    3130                            ,(add-suffix 'top) 

  • trunk/projects/bos/m2/packages.lisp

    r2838 r2846  
    163163           #:all-allocation-areas 
    164164           #:allocation-area-bounding-box 
     165           #:allocation-area-bounding-box2 
     166           #:allocation-areas-bounding-box 
    165167           #:allocation-area-active-p 
    166168           #:allocation-area-top 

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

    r2839 r2846  
    11(in-package :bos.m2) 
     2 
     3(pushnew 'hunchentoot:dispatch-easy-handlers hunchentoot:*dispatch-table*) 
    24 
    35(defun contract-image (rectangle) 
    …… 
    1517    nil)) 
    1618 
     19 
     20 
     21(hunchentoot:define-easy-handler (ci :uri "/ci") 
     22    ((step :init-form 1 :parameter-type 'integer)) 
     23  (let ((rectangle '(6666 5467 700 500))) 
     24    (geometry:with-rectangle rectangle 
     25      (with-image (image width height t) 
     26        (with-default-image (image)         
     27          (fill-image 0 0 :color (find-color 255 255 255)) 
     28          (do-rows (y) 
     29            (do-pixels-in-row (x) 
     30              (let* ((m2 (get-m2 (+ left (* step (floor x step))) (+ top (* step (floor y step))))) 
     31                     (contract (and m2 (m2-contract m2))))           
     32                (when (and contract (contract-paidp contract))                 
     33                  (setf (raw-pixel) (apply #'colorize-pixel (raw-pixel) (contract-color contract))))))) 
     34          (emit-image-to-browser image :png)))))) 
     35 
     36 
     37(defun alpha-test () 
     38  (with-image (image 200 200 t) 
     39    (with-default-image (image)         
     40      (let ((color (find-color 200 200 200 :alpha 100))) 
     41        (assert color) 
     42        (fill-image 0 0 :color color))       
     43      (cl-gd:write-image-to-file "/tmp/test3.png" :if-exists :supersede)))) 
     44 
     45;; (alpha-test) 
     46