cyrusharmon.org

Cyrus Harmon's new completely useless blog

 

More on the pixel macro and setf-expander

posted by cyrus in Lisp

Well, the previous attempts at the pixel setf-expander got most of the way there, but there are a couple of important changes since the last blog post, that I figured I should document for posterity's sake, lest someone run across the old post and attempt to base some future setf-expander off of the almost-but-not-quite-fully-working version contained therein.

First of all, Utz Uwe-Haus provided a number of fixes to get the fast path setf-expander working on Allegro. The first step was to get %get-image-dimensions working via a cltl2-signature-compatible version of variable-information. The second step was to look for types of the form (integer 0 255) instead of (unsigned-byte 8), which is how Allegro apparently reports (unsigned-byte 8)'s. Finally, it turns out that Allegro is finicky about needing things at compile-time in slightly different ways than SBCL is and it needs +max-image-channels+ define at compile-time, which sounds like the right thing to do in any case.

So with those changes in place, we have:

;;; support functions/constants for the pixel setf-expander need to  
;;; exist at compile time  
(eval-when (:compile-toplevel :load-toplevel :execute)  
  (defun %get-array-dimensions-from-type-decl (type-decl)  
    "Extract the array dimension specifier from type declaration TYPE-DECL."  
    #+(or sbcl ccl)  
    (and type-decl  
         ;; here we expect e.g. (TYPE SIMPLE-ARRAY (UNSIGNED-BYTE 8) (* * 3))  
         (listp type-decl)  
         (= (length type-decl) 4)  
         (fourth type-decl))  
    #+allegro  
    (and type-decl  
         ;; here we expect e.g. (TYPE (SIMPLE-ARRAY (INTEGER 0 255) (* * 3)))  
         (listp type-decl)  
         (= (length type-decl) 2)  
         (= (length (second type-decl)) 3)  
         (third (second type-decl))))  
 
  (defun %get-image-dimensions (image-var env)  
    #+(or sbcl ccl allegro)  
    (when (symbolp image-var)  
      (multiple-value-bind (binding-type localp declarations)  
          (opticl-cltl2:variable-information image-var env)  
        (declare (ignore binding-type localp))  
        (let ((type-decl (find 'type declarations :key #'car)))  
          (%get-array-dimensions-from-type-decl type-decl)))))  
 
  (defconstant +max-image-channels+ 4)) 

Ok, enough for the Allegro fixes. Now into the pixel setf-expander itself. There were a couple problems here. First, we weren't expanding image-var itself. This meant things would break if we tried to do:

(defmacro foo ()  
  `(make-8-bit-gray-image 4 4 :initial-element 32))  
 
(let ((moose))  
  (setf (pixel (setf moose (foo)) 0 0) 4)  
  moose) 

It turns out that we need to expand image-var itself with get-setf-expansion and deal with the 5 return values as appropriate. I think, that I can ignore the storing form, since I'm not actually, changing the value referred to by image-var and that I can just use the accessing form in the (setf (aref ...)) calls in the expander. If any language lawyers have any input here, it would be appreciated. Also, it's important to keep in mind that we need to return the temporary variables and their value forms from the get-setf-expansion. Ugh... This is all kind of a mess, but the end product is pretty neat! A non-consing idiomatic way to set pixel values, assuming we've declared the type of the image, but at least we can do so using the languages own (declare ...) mechanism rather than resorting to some sort of (with-fast-pixels ...) macro around all of the pixel/setf pixel calls.

Here's the final product:

(define-setf-expander pixel (image-var y x &environment env)  
  (multiple-value-bind (dummies vals newval setter getter)  
      (get-setf-expansion image-var env)  
    (declare (ignore newval setter))  
    (let ((image-dimensions (%get-image-dimensions getter env)))  
      (if image-dimensions  
          (let ((arity (or (and (= (length image-dimensions) 3)  
                                (third image-dimensions))  
                           1))  
                (temp-y (gensym))  
                (temp-x (gensym)))  
            (if (= arity 1)  
                (let ((store (gensym)))  
                  (values `(,@dummies ,temp-y ,temp-x)  
                          `(,@vals ,y ,x)  
                          `(,store)  
                          `(setf (aref ,getter ,temp-y ,temp-x) ,store)  
                          `(aref ,getter ,temp-y ,temp-x)))  
                (let ((stores (map-into (make-list arity) #'gensym)))  
                  (values `(,@dummies ,temp-y ,temp-x)  
                          `(,@vals ,y ,x)  
                          stores  
                          `(progn (setf ,@(loop for i from 0  
                                             for store in stores  
                                             collect `(aref ,getter ,temp-y ,temp-x ,i)  
                                             collect store))  
                                  (values ,@stores))  
                          `(values ,@(loop for i from 0 below (length stores)  
                                        collect `(aref ,getter ,temp-y ,temp-x ,i)))))))  
          (let ((syms (map-into (make-list +max-image-channels+) #'gensym)))  
            (let ((temp-y (gensym))  
                  (temp-x (gensym)))  
              (values `(,@dummies ,temp-y ,temp-x)  
                      `(,@vals ,y ,x)  
                      syms  
                      `(ecase (array-rank ,getter)  
                         (3 (let ((d (array-dimension ,getter 2)))  
                              (case d  
                                (1  
                                 (values  
                                  (setf (aref ,getter ,temp-y ,temp-x 0) ,(elt syms 0))))  
                                (2  
                                 (values  
                                  (setf (aref ,getter ,temp-y ,temp-x 0) ,(elt syms 0))  
                                  (setf (aref ,getter ,temp-y ,temp-x 1) ,(elt syms 1))))  
                                (3  
                                 (values  
                                  (setf (aref ,getter ,temp-y ,temp-x 0) ,(elt syms 0))  
                                  (setf (aref ,getter ,temp-y ,temp-x 1) ,(elt syms 1))  
                                  (setf (aref ,getter ,temp-y ,temp-x 2) ,(elt syms 2))))  
                                (4  
                                 (values  
                                  (setf (aref ,getter ,temp-y ,temp-x 0) ,(elt syms 0))  
                                  (setf (aref ,getter ,temp-y ,temp-x 1) ,(elt syms 1))  
                                  (setf (aref ,getter ,temp-y ,temp-x 2) ,(elt syms 2))  
                                  (setf (aref ,getter ,temp-y ,temp-x 3) ,(elt syms 3))))  
                                (t (loop for i below d  
                                      collect (setf (aref ,getter ,temp-y ,temp-x i) (elt (list ,@syms) i)))))))  
                         (2 (setf (aref ,getter ,temp-y ,temp-x) ,(elt syms 0))))  
                      `(ecase (array-rank ,getter)  
                         (3  
                          (let ((d (array-dimension ,getter 2)))  
                            (case d  
                              (1  
                               (values  
                                (aref ,getter ,temp-y ,temp-x 0)))  
                              (2  
                               (values  
                                (aref ,getter ,temp-y ,temp-x 0)  
                                (aref ,getter ,temp-y ,temp-x 1)))  
                              (3  
                               (values  
                                (aref ,getter ,temp-y ,temp-x 0)  
                                (aref ,getter ,temp-y ,temp-x 1)  
                                (aref ,getter ,temp-y ,temp-x 2)))  
                              (4  
                               (values  
                                (aref ,getter ,temp-y ,temp-x 0)  
                                (aref ,getter ,temp-y ,temp-x 1)  
                                (aref ,getter ,temp-y ,temp-x 2)  
                                (aref ,getter ,temp-y ,temp-x 3)))  
                              (t (values-list  
                                  (loop for i below d  
                                     collect (aref ,getter ,temp-y ,temp-x i)))))))  
                         (2 (aref ,getter ,temp-y ,temp-x))))))))))  
 
(defmacro pixel (image-var y x &environment env)  
  (let ((image-dimensions (%get-image-dimensions image-var env)))  
    (if image-dimensions  
        (progn  
          (ecase (length image-dimensions)  
            (2 `(aref ,image-var ,y ,x))  
            (3 `(values ,@(loop for i below (third image-dimensions)  
                             collect `(aref ,image-var ,y ,x ,i))))))  
        `(ecase (array-rank ,image-var)  
           (2 (aref ,image-var ,y ,x))  
           (3 (ecase (array-dimension ,image-var 2)  
                (1 (values  
                    (aref ,image-var ,y ,x 0)))  
                (2 (values  
                    (aref ,image-var ,y ,x 0)  
                    (aref ,image-var ,y ,x 1)))  
                (3 (values  
                    (aref ,image-var ,y ,x 0)  
                    (aref ,image-var ,y ,x 1)  
                    (aref ,image-var ,y ,x 2)))  
                (4 (values  
                    (aref ,image-var ,y ,x 0)  
                    (aref ,image-var ,y ,x 1)  
                    (aref ,image-var ,y ,x 2)  
                    (aref ,image-var ,y ,x 3))))))))) 

Finally, if you've gotten this far and you want to see opticl in action, check out spectacle a CLIM application for viewing images that uses opticl for the image loading, representation, etc... On SBCL, and presumably Allegro, it has nice responsive scrolling/zooming/rotating/etc..., but if the pixel stuff conses (as it seems to do on CCL), it can be a bit sluggish.

More on the pixel macro and setf-expander